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"
59 #ifndef ADA_RETAIN_DOTS
60 #define ADA_RETAIN_DOTS 0
63 /* Define whether or not the C operator '/' truncates towards zero for
64 differently signed operands (truncation direction is undefined in C).
65 Copied from valarith.c. */
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
72 static void extract_string (CORE_ADDR addr
, char *buf
);
74 static void modify_general_field (char *, LONGEST
, int, int);
76 static struct type
*desc_base_type (struct type
*);
78 static struct type
*desc_bounds_type (struct type
*);
80 static struct value
*desc_bounds (struct value
*);
82 static int fat_pntr_bounds_bitpos (struct type
*);
84 static int fat_pntr_bounds_bitsize (struct type
*);
86 static struct type
*desc_data_type (struct type
*);
88 static struct value
*desc_data (struct value
*);
90 static int fat_pntr_data_bitpos (struct type
*);
92 static int fat_pntr_data_bitsize (struct type
*);
94 static struct value
*desc_one_bound (struct value
*, int, int);
96 static int desc_bound_bitpos (struct type
*, int, int);
98 static int desc_bound_bitsize (struct type
*, int, int);
100 static struct type
*desc_index_type (struct type
*, int);
102 static int desc_arity (struct type
*);
104 static int ada_type_match (struct type
*, struct type
*, int);
106 static int ada_args_match (struct symbol
*, struct value
**, int);
108 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
110 static struct value
*convert_actual (struct value
*, struct type
*,
113 static struct value
*make_array_descriptor (struct type
*, struct value
*,
116 static void ada_add_block_symbols (struct obstack
*,
117 struct block
*, const char *,
118 domain_enum
, struct objfile
*,
119 struct symtab
*, int);
121 static int is_nonfunction (struct ada_symbol_info
*, int);
123 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
124 struct block
*, struct symtab
*);
126 static int num_defns_collected (struct obstack
*);
128 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
130 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
131 *, const char *, int,
134 static struct symtab
*symtab_for_sym (struct symbol
*);
136 static struct value
*resolve_subexp (struct expression
**, int *, int,
139 static void replace_operator_with_call (struct expression
**, int, int, int,
140 struct symbol
*, struct block
*);
142 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
144 static char *ada_op_name (enum exp_opcode
);
146 static const char *ada_decoded_op_name (enum exp_opcode
);
148 static int numeric_type_p (struct type
*);
150 static int integer_type_p (struct type
*);
152 static int scalar_type_p (struct type
*);
154 static int discrete_type_p (struct type
*);
156 static enum ada_renaming_category
parse_old_style_renaming (struct type
*,
161 static struct symbol
*find_old_style_renaming_symbol (const char *,
164 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
167 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
170 static struct value
*evaluate_subexp_type (struct expression
*, int *);
172 static int is_dynamic_field (struct type
*, int);
174 static struct type
*to_fixed_variant_branch_type (struct type
*,
176 CORE_ADDR
, struct value
*);
178 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
180 static struct type
*to_fixed_range_type (char *, struct value
*,
183 static struct type
*to_static_fixed_type (struct type
*);
185 static struct value
*unwrap_value (struct value
*);
187 static struct type
*packed_array_type (struct type
*, long *);
189 static struct type
*decode_packed_array_type (struct type
*);
191 static struct value
*decode_packed_array (struct value
*);
193 static struct value
*value_subscript_packed (struct value
*, int,
196 static void move_bits (gdb_byte
*, int, const gdb_byte
*, int, int);
198 static struct value
*coerce_unspec_val_to_type (struct value
*,
201 static struct value
*get_var_value (char *, char *);
203 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
205 static int equiv_types (struct type
*, struct type
*);
207 static int is_name_suffix (const char *);
209 static int wild_match (const char *, int, const char *);
211 static struct value
*ada_coerce_ref (struct value
*);
213 static LONGEST
pos_atr (struct value
*);
215 static struct value
*value_pos_atr (struct value
*);
217 static struct value
*value_val_atr (struct type
*, struct value
*);
219 static struct symbol
*standard_lookup (const char *, const struct block
*,
222 static struct value
*ada_search_struct_field (char *, struct value
*, int,
225 static struct value
*ada_value_primitive_field (struct value
*, int, int,
228 static int find_struct_field (char *, struct type
*, int,
229 struct type
**, int *, int *, int *, int *);
231 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
234 static struct value
*ada_to_fixed_value (struct value
*);
236 static int ada_resolve_function (struct ada_symbol_info
*, int,
237 struct value
**, int, const char *,
240 static struct value
*ada_coerce_to_simple_array (struct value
*);
242 static int ada_is_direct_array_type (struct type
*);
244 static void ada_language_arch_info (struct gdbarch
*,
245 struct language_arch_info
*);
247 static void check_size (const struct type
*);
249 static struct value
*ada_index_struct_field (int, struct value
*, int,
252 static struct value
*assign_aggregate (struct value
*, struct value
*,
253 struct expression
*, int *, enum noside
);
255 static void aggregate_assign_from_choices (struct value
*, struct value
*,
257 int *, LONGEST
*, int *,
258 int, LONGEST
, LONGEST
);
260 static void aggregate_assign_positional (struct value
*, struct value
*,
262 int *, LONGEST
*, int *, int,
266 static void aggregate_assign_others (struct value
*, struct value
*,
268 int *, LONGEST
*, int, LONGEST
, LONGEST
);
271 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
274 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
277 static void ada_forward_operator_length (struct expression
*, int, int *,
282 /* Maximum-sized dynamic type. */
283 static unsigned int varsize_limit
;
285 /* FIXME: brobecker/2003-09-17: No longer a const because it is
286 returned by a function that does not return a const char *. */
287 static char *ada_completer_word_break_characters
=
289 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
291 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
294 /* The name of the symbol to use to get the name of the main subprogram. */
295 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
296 = "__gnat_ada_main_program_name";
298 /* Limit on the number of warnings to raise per expression evaluation. */
299 static int warning_limit
= 2;
301 /* Number of warning messages issued; reset to 0 by cleanups after
302 expression evaluation. */
303 static int warnings_issued
= 0;
305 static const char *known_runtime_file_name_patterns
[] = {
306 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
309 static const char *known_auxiliary_function_name_patterns
[] = {
310 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
313 /* Space for allocating results of ada_lookup_symbol_list. */
314 static struct obstack symbol_list_obstack
;
320 ada_get_gdb_completer_word_break_characters (void)
322 return ada_completer_word_break_characters
;
325 /* Print an array element index using the Ada syntax. */
328 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
329 int format
, enum val_prettyprint pretty
)
331 LA_VALUE_PRINT (index_value
, stream
, format
, pretty
);
332 fprintf_filtered (stream
, " => ");
335 /* Read the string located at ADDR from the inferior and store the
339 extract_string (CORE_ADDR addr
, char *buf
)
343 /* Loop, reading one byte at a time, until we reach the '\000'
344 end-of-string marker. */
347 target_read_memory (addr
+ char_index
* sizeof (char),
348 buf
+ char_index
* sizeof (char), sizeof (char));
351 while (buf
[char_index
- 1] != '\000');
354 /* Assuming VECT points to an array of *SIZE objects of size
355 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
356 updating *SIZE as necessary and returning the (new) array. */
359 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
361 if (*size
< min_size
)
364 if (*size
< min_size
)
366 vect
= xrealloc (vect
, *size
* element_size
);
371 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
372 suffix of FIELD_NAME beginning "___". */
375 field_name_match (const char *field_name
, const char *target
)
377 int len
= strlen (target
);
379 (strncmp (field_name
, target
, len
) == 0
380 && (field_name
[len
] == '\0'
381 || (strncmp (field_name
+ len
, "___", 3) == 0
382 && strcmp (field_name
+ strlen (field_name
) - 6,
387 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
388 FIELD_NAME, and return its index. This function also handles fields
389 whose name have ___ suffixes because the compiler sometimes alters
390 their name by adding such a suffix to represent fields with certain
391 constraints. If the field could not be found, return a negative
392 number if MAYBE_MISSING is set. Otherwise raise an error. */
395 ada_get_field_index (const struct type
*type
, const char *field_name
,
399 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
400 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
404 error (_("Unable to find field %s in struct %s. Aborting"),
405 field_name
, TYPE_NAME (type
));
410 /* The length of the prefix of NAME prior to any "___" suffix. */
413 ada_name_prefix_len (const char *name
)
419 const char *p
= strstr (name
, "___");
421 return strlen (name
);
427 /* Return non-zero if SUFFIX is a suffix of STR.
428 Return zero if STR is null. */
431 is_suffix (const char *str
, const char *suffix
)
437 len2
= strlen (suffix
);
438 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
441 /* Create a value of type TYPE whose contents come from VALADDR, if it
442 is non-null, and whose memory address (in the inferior) is
446 value_from_contents_and_address (struct type
*type
,
447 const gdb_byte
*valaddr
,
450 struct value
*v
= allocate_value (type
);
452 set_value_lazy (v
, 1);
454 memcpy (value_contents_raw (v
), valaddr
, TYPE_LENGTH (type
));
455 VALUE_ADDRESS (v
) = address
;
457 VALUE_LVAL (v
) = lval_memory
;
461 /* The contents of value VAL, treated as a value of type TYPE. The
462 result is an lval in memory if VAL is. */
464 static struct value
*
465 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
467 type
= ada_check_typedef (type
);
468 if (value_type (val
) == type
)
472 struct value
*result
;
474 /* Make sure that the object size is not unreasonable before
475 trying to allocate some memory for it. */
478 result
= allocate_value (type
);
479 VALUE_LVAL (result
) = VALUE_LVAL (val
);
480 set_value_bitsize (result
, value_bitsize (val
));
481 set_value_bitpos (result
, value_bitpos (val
));
482 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
484 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
485 set_value_lazy (result
, 1);
487 memcpy (value_contents_raw (result
), value_contents (val
),
493 static const gdb_byte
*
494 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
499 return valaddr
+ offset
;
503 cond_offset_target (CORE_ADDR address
, long offset
)
508 return address
+ offset
;
511 /* Issue a warning (as for the definition of warning in utils.c, but
512 with exactly one argument rather than ...), unless the limit on the
513 number of warnings has passed during the evaluation of the current
516 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
517 provided by "complaint". */
518 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
521 lim_warning (const char *format
, ...)
524 va_start (args
, format
);
526 warnings_issued
+= 1;
527 if (warnings_issued
<= warning_limit
)
528 vwarning (format
, args
);
533 /* Issue an error if the size of an object of type T is unreasonable,
534 i.e. if it would be a bad idea to allocate a value of this type in
538 check_size (const struct type
*type
)
540 if (TYPE_LENGTH (type
) > varsize_limit
)
541 error (_("object size is larger than varsize-limit"));
545 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
546 gdbtypes.h, but some of the necessary definitions in that file
547 seem to have gone missing. */
549 /* Maximum value of a SIZE-byte signed integer type. */
551 max_of_size (int size
)
553 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
554 return top_bit
| (top_bit
- 1);
557 /* Minimum value of a SIZE-byte signed integer type. */
559 min_of_size (int size
)
561 return -max_of_size (size
) - 1;
564 /* Maximum value of a SIZE-byte unsigned integer type. */
566 umax_of_size (int size
)
568 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
569 return top_bit
| (top_bit
- 1);
572 /* Maximum value of integral type T, as a signed quantity. */
574 max_of_type (struct type
*t
)
576 if (TYPE_UNSIGNED (t
))
577 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
579 return max_of_size (TYPE_LENGTH (t
));
582 /* Minimum value of integral type T, as a signed quantity. */
584 min_of_type (struct type
*t
)
586 if (TYPE_UNSIGNED (t
))
589 return min_of_size (TYPE_LENGTH (t
));
592 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
593 static struct value
*
594 discrete_type_high_bound (struct type
*type
)
596 switch (TYPE_CODE (type
))
598 case TYPE_CODE_RANGE
:
599 return value_from_longest (TYPE_TARGET_TYPE (type
),
600 TYPE_HIGH_BOUND (type
));
603 value_from_longest (type
,
604 TYPE_FIELD_BITPOS (type
,
605 TYPE_NFIELDS (type
) - 1));
607 return value_from_longest (type
, max_of_type (type
));
609 error (_("Unexpected type in discrete_type_high_bound."));
613 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
614 static struct value
*
615 discrete_type_low_bound (struct type
*type
)
617 switch (TYPE_CODE (type
))
619 case TYPE_CODE_RANGE
:
620 return value_from_longest (TYPE_TARGET_TYPE (type
),
621 TYPE_LOW_BOUND (type
));
623 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
625 return value_from_longest (type
, min_of_type (type
));
627 error (_("Unexpected type in discrete_type_low_bound."));
631 /* The identity on non-range types. For range types, the underlying
632 non-range scalar type. */
635 base_type (struct type
*type
)
637 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
639 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
641 type
= TYPE_TARGET_TYPE (type
);
647 /* Language Selection */
649 /* If the main program is in Ada, return language_ada, otherwise return LANG
650 (the main program is in Ada iif the adainit symbol is found).
652 MAIN_PST is not used. */
655 ada_update_initial_language (enum language lang
,
656 struct partial_symtab
*main_pst
)
658 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
659 (struct objfile
*) NULL
) != NULL
)
665 /* If the main procedure is written in Ada, then return its name.
666 The result is good until the next call. Return NULL if the main
667 procedure doesn't appear to be in Ada. */
672 struct minimal_symbol
*msym
;
673 CORE_ADDR main_program_name_addr
;
674 static char main_program_name
[1024];
676 /* For Ada, the name of the main procedure is stored in a specific
677 string constant, generated by the binder. Look for that symbol,
678 extract its address, and then read that string. If we didn't find
679 that string, then most probably the main procedure is not written
681 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
685 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
686 if (main_program_name_addr
== 0)
687 error (_("Invalid address for Ada main program name."));
689 extract_string (main_program_name_addr
, main_program_name
);
690 return main_program_name
;
693 /* The main procedure doesn't seem to be in Ada. */
699 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
702 const struct ada_opname_map ada_opname_table
[] = {
703 {"Oadd", "\"+\"", BINOP_ADD
},
704 {"Osubtract", "\"-\"", BINOP_SUB
},
705 {"Omultiply", "\"*\"", BINOP_MUL
},
706 {"Odivide", "\"/\"", BINOP_DIV
},
707 {"Omod", "\"mod\"", BINOP_MOD
},
708 {"Orem", "\"rem\"", BINOP_REM
},
709 {"Oexpon", "\"**\"", BINOP_EXP
},
710 {"Olt", "\"<\"", BINOP_LESS
},
711 {"Ole", "\"<=\"", BINOP_LEQ
},
712 {"Ogt", "\">\"", BINOP_GTR
},
713 {"Oge", "\">=\"", BINOP_GEQ
},
714 {"Oeq", "\"=\"", BINOP_EQUAL
},
715 {"One", "\"/=\"", BINOP_NOTEQUAL
},
716 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
717 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
718 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
719 {"Oconcat", "\"&\"", BINOP_CONCAT
},
720 {"Oabs", "\"abs\"", UNOP_ABS
},
721 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
722 {"Oadd", "\"+\"", UNOP_PLUS
},
723 {"Osubtract", "\"-\"", UNOP_NEG
},
727 /* Return non-zero if STR should be suppressed in info listings. */
730 is_suppressed_name (const char *str
)
732 if (strncmp (str
, "_ada_", 5) == 0)
734 if (str
[0] == '_' || str
[0] == '\000')
739 const char *suffix
= strstr (str
, "___");
740 if (suffix
!= NULL
&& suffix
[3] != 'X')
743 suffix
= str
+ strlen (str
);
744 for (p
= suffix
- 1; p
!= str
; p
-= 1)
748 if (p
[0] == 'X' && p
[-1] != '_')
752 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
753 if (strncmp (ada_opname_table
[i
].encoded
, p
,
754 strlen (ada_opname_table
[i
].encoded
)) == 0)
763 /* The "encoded" form of DECODED, according to GNAT conventions.
764 The result is valid until the next call to ada_encode. */
767 ada_encode (const char *decoded
)
769 static char *encoding_buffer
= NULL
;
770 static size_t encoding_buffer_size
= 0;
777 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
778 2 * strlen (decoded
) + 10);
781 for (p
= decoded
; *p
!= '\0'; p
+= 1)
783 if (!ADA_RETAIN_DOTS
&& *p
== '.')
785 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
790 const struct ada_opname_map
*mapping
;
792 for (mapping
= ada_opname_table
;
793 mapping
->encoded
!= NULL
794 && strncmp (mapping
->decoded
, p
,
795 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
797 if (mapping
->encoded
== NULL
)
798 error (_("invalid Ada operator name: %s"), p
);
799 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
800 k
+= strlen (mapping
->encoded
);
805 encoding_buffer
[k
] = *p
;
810 encoding_buffer
[k
] = '\0';
811 return encoding_buffer
;
814 /* Return NAME folded to lower case, or, if surrounded by single
815 quotes, unfolded, but with the quotes stripped away. Result good
819 ada_fold_name (const char *name
)
821 static char *fold_buffer
= NULL
;
822 static size_t fold_buffer_size
= 0;
824 int len
= strlen (name
);
825 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
829 strncpy (fold_buffer
, name
+ 1, len
- 2);
830 fold_buffer
[len
- 2] = '\000';
835 for (i
= 0; i
<= len
; i
+= 1)
836 fold_buffer
[i
] = tolower (name
[i
]);
842 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
845 is_lower_alphanum (const char c
)
847 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
851 . Discard trailing .{DIGIT}+, ${DIGIT}+ or ___{DIGIT}+
852 These are suffixes introduced by GNAT5 to nested subprogram
853 names, and do not serve any purpose for the debugger.
854 . Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
855 . Discard final N if it follows a lowercase alphanumeric character
856 (protected object subprogram suffix)
857 . Convert other instances of embedded "__" to `.'.
858 . Discard leading _ada_.
859 . Convert operator names to the appropriate quoted symbols.
860 . Remove everything after first ___ if it is followed by
862 . Replace TK__ with __, and a trailing B or TKB with nothing.
863 . Replace _[EB]{DIGIT}+[sb] with nothing (protected object entries)
864 . Put symbols that should be suppressed in <...> brackets.
865 . Remove trailing X[bn]* suffix (indicating names in package bodies).
867 The resulting string is valid until the next call of ada_decode.
868 If the string is unchanged by demangling, the original string pointer
872 ada_decode (const char *encoded
)
879 static char *decoding_buffer
= NULL
;
880 static size_t decoding_buffer_size
= 0;
882 if (strncmp (encoded
, "_ada_", 5) == 0)
885 if (encoded
[0] == '_' || encoded
[0] == '<')
888 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+ or __{DIGIT}+. */
889 len0
= strlen (encoded
);
890 if (len0
> 1 && isdigit (encoded
[len0
- 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)
905 /* Remove trailing N. */
907 /* Protected entry subprograms are broken into two
908 separate subprograms: The first one is unprotected, and has
909 a 'N' suffix; the second is the protected version, and has
910 the 'P' suffix. The second calls the first one after handling
911 the protection. Since the P subprograms are internally generated,
912 we leave these names undecoded, giving the user a clue that this
913 entity is internal. */
916 && encoded
[len0
- 1] == 'N'
917 && (isdigit (encoded
[len0
- 2]) || islower (encoded
[len0
- 2])))
920 /* Remove the ___X.* suffix if present. Do not forget to verify that
921 the suffix is located before the current "end" of ENCODED. We want
922 to avoid re-matching parts of ENCODED that have previously been
923 marked as discarded (by decrementing LEN0). */
924 p
= strstr (encoded
, "___");
925 if (p
!= NULL
&& p
- encoded
< len0
- 3)
933 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
936 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
939 /* Make decoded big enough for possible expansion by operator name. */
940 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
941 decoded
= decoding_buffer
;
943 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
946 while ((i
>= 0 && isdigit (encoded
[i
]))
947 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
949 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
951 else if (encoded
[i
] == '$')
955 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
956 decoded
[j
] = encoded
[i
];
961 if (at_start_name
&& encoded
[i
] == 'O')
964 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
966 int op_len
= strlen (ada_opname_table
[k
].encoded
);
967 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
969 && !isalnum (encoded
[i
+ op_len
]))
971 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
974 j
+= strlen (ada_opname_table
[k
].decoded
);
978 if (ada_opname_table
[k
].encoded
!= NULL
)
983 /* Replace "TK__" with "__", which will eventually be translated
984 into "." (just below). */
986 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
989 /* Remove _E{DIGITS}+[sb] */
991 /* Just as for protected object subprograms, there are 2 categories
992 of subprograms created by the compiler for each entry. The first
993 one implements the actual entry code, and has a suffix following
994 the convention above; the second one implements the barrier and
995 uses the same convention as above, except that the 'E' is replaced
998 Just as above, we do not decode the name of barrier functions
999 to give the user a clue that the code he is debugging has been
1000 internally generated. */
1002 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1003 && isdigit (encoded
[i
+2]))
1007 while (k
< len0
&& isdigit (encoded
[k
]))
1011 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1014 /* Just as an extra precaution, make sure that if this
1015 suffix is followed by anything else, it is a '_'.
1016 Otherwise, we matched this sequence by accident. */
1018 || (k
< len0
&& encoded
[k
] == '_'))
1023 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1024 the GNAT front-end in protected object subprograms. */
1027 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1029 /* Backtrack a bit up until we reach either the begining of
1030 the encoded name, or "__". Make sure that we only find
1031 digits or lowercase characters. */
1032 const char *ptr
= encoded
+ i
- 1;
1034 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1037 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1041 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1045 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1049 else if (!ADA_RETAIN_DOTS
1050 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1059 decoded
[j
] = encoded
[i
];
1064 decoded
[j
] = '\000';
1066 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1067 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1070 if (strcmp (decoded
, encoded
) == 0)
1076 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1077 decoded
= decoding_buffer
;
1078 if (encoded
[0] == '<')
1079 strcpy (decoded
, encoded
);
1081 sprintf (decoded
, "<%s>", encoded
);
1086 /* Table for keeping permanent unique copies of decoded names. Once
1087 allocated, names in this table are never released. While this is a
1088 storage leak, it should not be significant unless there are massive
1089 changes in the set of decoded names in successive versions of a
1090 symbol table loaded during a single session. */
1091 static struct htab
*decoded_names_store
;
1093 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1094 in the language-specific part of GSYMBOL, if it has not been
1095 previously computed. Tries to save the decoded name in the same
1096 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1097 in any case, the decoded symbol has a lifetime at least that of
1099 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1100 const, but nevertheless modified to a semantically equivalent form
1101 when a decoded name is cached in it.
1105 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1108 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1109 if (*resultp
== NULL
)
1111 const char *decoded
= ada_decode (gsymbol
->name
);
1112 if (gsymbol
->bfd_section
!= NULL
)
1114 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
1117 struct objfile
*objf
;
1120 if (obfd
== objf
->obfd
)
1122 *resultp
= obsavestring (decoded
, strlen (decoded
),
1123 &objf
->objfile_obstack
);
1129 /* Sometimes, we can't find a corresponding objfile, in which
1130 case, we put the result on the heap. Since we only decode
1131 when needed, we hope this usually does not cause a
1132 significant memory leak (FIXME). */
1133 if (*resultp
== NULL
)
1135 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1138 *slot
= xstrdup (decoded
);
1147 ada_la_decode (const char *encoded
, int options
)
1149 return xstrdup (ada_decode (encoded
));
1152 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1153 suffixes that encode debugging information or leading _ada_ on
1154 SYM_NAME (see is_name_suffix commentary for the debugging
1155 information that is ignored). If WILD, then NAME need only match a
1156 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1157 either argument is NULL. */
1160 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1162 if (sym_name
== NULL
|| name
== NULL
)
1165 return wild_match (name
, strlen (name
), sym_name
);
1168 int len_name
= strlen (name
);
1169 return (strncmp (sym_name
, name
, len_name
) == 0
1170 && is_name_suffix (sym_name
+ len_name
))
1171 || (strncmp (sym_name
, "_ada_", 5) == 0
1172 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1173 && is_name_suffix (sym_name
+ len_name
+ 5));
1177 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1178 suppressed in info listings. */
1181 ada_suppress_symbol_printing (struct symbol
*sym
)
1183 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1186 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1192 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1194 static char *bound_name
[] = {
1195 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1196 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1199 /* Maximum number of array dimensions we are prepared to handle. */
1201 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1203 /* Like modify_field, but allows bitpos > wordlength. */
1206 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1208 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1212 /* The desc_* routines return primitive portions of array descriptors
1215 /* The descriptor or array type, if any, indicated by TYPE; removes
1216 level of indirection, if needed. */
1218 static struct type
*
1219 desc_base_type (struct type
*type
)
1223 type
= ada_check_typedef (type
);
1225 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1226 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1227 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1232 /* True iff TYPE indicates a "thin" array pointer type. */
1235 is_thin_pntr (struct type
*type
)
1238 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1239 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1242 /* The descriptor type for thin pointer type TYPE. */
1244 static struct type
*
1245 thin_descriptor_type (struct type
*type
)
1247 struct type
*base_type
= desc_base_type (type
);
1248 if (base_type
== NULL
)
1250 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1254 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1255 if (alt_type
== NULL
)
1262 /* A pointer to the array data for thin-pointer value VAL. */
1264 static struct value
*
1265 thin_data_pntr (struct value
*val
)
1267 struct type
*type
= value_type (val
);
1268 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1269 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1272 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1273 VALUE_ADDRESS (val
) + value_offset (val
));
1276 /* True iff TYPE indicates a "thick" array pointer type. */
1279 is_thick_pntr (struct type
*type
)
1281 type
= desc_base_type (type
);
1282 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1283 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1286 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1287 pointer to one, the type of its bounds data; otherwise, NULL. */
1289 static struct type
*
1290 desc_bounds_type (struct type
*type
)
1294 type
= desc_base_type (type
);
1298 else if (is_thin_pntr (type
))
1300 type
= thin_descriptor_type (type
);
1303 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1305 return ada_check_typedef (r
);
1307 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1309 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1311 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1316 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1317 one, a pointer to its bounds data. Otherwise NULL. */
1319 static struct value
*
1320 desc_bounds (struct value
*arr
)
1322 struct type
*type
= ada_check_typedef (value_type (arr
));
1323 if (is_thin_pntr (type
))
1325 struct type
*bounds_type
=
1326 desc_bounds_type (thin_descriptor_type (type
));
1329 if (bounds_type
== NULL
)
1330 error (_("Bad GNAT array descriptor"));
1332 /* NOTE: The following calculation is not really kosher, but
1333 since desc_type is an XVE-encoded type (and shouldn't be),
1334 the correct calculation is a real pain. FIXME (and fix GCC). */
1335 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1336 addr
= value_as_long (arr
);
1338 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1341 value_from_longest (lookup_pointer_type (bounds_type
),
1342 addr
- TYPE_LENGTH (bounds_type
));
1345 else if (is_thick_pntr (type
))
1346 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1347 _("Bad GNAT array descriptor"));
1352 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1353 position of the field containing the address of the bounds data. */
1356 fat_pntr_bounds_bitpos (struct type
*type
)
1358 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1361 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1362 size of the field containing the address of the bounds data. */
1365 fat_pntr_bounds_bitsize (struct type
*type
)
1367 type
= desc_base_type (type
);
1369 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1370 return TYPE_FIELD_BITSIZE (type
, 1);
1372 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1375 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1376 pointer to one, the type of its array data (a
1377 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1378 ada_type_of_array to get an array type with bounds data. */
1380 static struct type
*
1381 desc_data_type (struct type
*type
)
1383 type
= desc_base_type (type
);
1385 /* NOTE: The following is bogus; see comment in desc_bounds. */
1386 if (is_thin_pntr (type
))
1387 return lookup_pointer_type
1388 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1389 else if (is_thick_pntr (type
))
1390 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1395 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1398 static struct value
*
1399 desc_data (struct value
*arr
)
1401 struct type
*type
= value_type (arr
);
1402 if (is_thin_pntr (type
))
1403 return thin_data_pntr (arr
);
1404 else if (is_thick_pntr (type
))
1405 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1406 _("Bad GNAT array descriptor"));
1412 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1413 position of the field containing the address of the data. */
1416 fat_pntr_data_bitpos (struct type
*type
)
1418 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1421 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1422 size of the field containing the address of the data. */
1425 fat_pntr_data_bitsize (struct type
*type
)
1427 type
= desc_base_type (type
);
1429 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1430 return TYPE_FIELD_BITSIZE (type
, 0);
1432 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1435 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1436 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1437 bound, if WHICH is 1. The first bound is I=1. */
1439 static struct value
*
1440 desc_one_bound (struct value
*bounds
, int i
, int which
)
1442 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1443 _("Bad GNAT array descriptor bounds"));
1446 /* If BOUNDS is an array-bounds structure type, return the bit position
1447 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1448 bound, if WHICH is 1. The first bound is I=1. */
1451 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1453 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1456 /* If BOUNDS is an array-bounds structure type, return the bit field size
1457 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1458 bound, if WHICH is 1. The first bound is I=1. */
1461 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1463 type
= desc_base_type (type
);
1465 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1466 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1468 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1471 /* If TYPE is the type of an array-bounds structure, the type of its
1472 Ith bound (numbering from 1). Otherwise, NULL. */
1474 static struct type
*
1475 desc_index_type (struct type
*type
, int i
)
1477 type
= desc_base_type (type
);
1479 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1480 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1485 /* The number of index positions in the array-bounds type TYPE.
1486 Return 0 if TYPE is NULL. */
1489 desc_arity (struct type
*type
)
1491 type
= desc_base_type (type
);
1494 return TYPE_NFIELDS (type
) / 2;
1498 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1499 an array descriptor type (representing an unconstrained array
1503 ada_is_direct_array_type (struct type
*type
)
1507 type
= ada_check_typedef (type
);
1508 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1509 || ada_is_array_descriptor_type (type
));
1512 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1516 ada_is_array_type (struct type
*type
)
1519 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1520 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1521 type
= TYPE_TARGET_TYPE (type
);
1522 return ada_is_direct_array_type (type
);
1525 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1528 ada_is_simple_array_type (struct type
*type
)
1532 type
= ada_check_typedef (type
);
1533 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1534 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1535 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1538 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1541 ada_is_array_descriptor_type (struct type
*type
)
1543 struct type
*data_type
= desc_data_type (type
);
1547 type
= ada_check_typedef (type
);
1550 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1551 && TYPE_TARGET_TYPE (data_type
) != NULL
1552 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1553 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1554 && desc_arity (desc_bounds_type (type
)) > 0;
1557 /* Non-zero iff type is a partially mal-formed GNAT array
1558 descriptor. FIXME: This is to compensate for some problems with
1559 debugging output from GNAT. Re-examine periodically to see if it
1563 ada_is_bogus_array_descriptor (struct type
*type
)
1567 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1568 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1569 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1570 && !ada_is_array_descriptor_type (type
);
1574 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1575 (fat pointer) returns the type of the array data described---specifically,
1576 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1577 in from the descriptor; otherwise, they are left unspecified. If
1578 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1579 returns NULL. The result is simply the type of ARR if ARR is not
1582 ada_type_of_array (struct value
*arr
, int bounds
)
1584 if (ada_is_packed_array_type (value_type (arr
)))
1585 return decode_packed_array_type (value_type (arr
));
1587 if (!ada_is_array_descriptor_type (value_type (arr
)))
1588 return value_type (arr
);
1592 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1595 struct type
*elt_type
;
1597 struct value
*descriptor
;
1598 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1600 elt_type
= ada_array_element_type (value_type (arr
), -1);
1601 arity
= ada_array_arity (value_type (arr
));
1603 if (elt_type
== NULL
|| arity
== 0)
1604 return ada_check_typedef (value_type (arr
));
1606 descriptor
= desc_bounds (arr
);
1607 if (value_as_long (descriptor
) == 0)
1611 struct type
*range_type
= alloc_type (objf
);
1612 struct type
*array_type
= alloc_type (objf
);
1613 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1614 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1617 create_range_type (range_type
, value_type (low
),
1618 longest_to_int (value_as_long (low
)),
1619 longest_to_int (value_as_long (high
)));
1620 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1623 return lookup_pointer_type (elt_type
);
1627 /* If ARR does not represent an array, returns ARR unchanged.
1628 Otherwise, returns either a standard GDB array with bounds set
1629 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1630 GDB array. Returns NULL if ARR is a null fat pointer. */
1633 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1635 if (ada_is_array_descriptor_type (value_type (arr
)))
1637 struct type
*arrType
= ada_type_of_array (arr
, 1);
1638 if (arrType
== NULL
)
1640 return value_cast (arrType
, value_copy (desc_data (arr
)));
1642 else if (ada_is_packed_array_type (value_type (arr
)))
1643 return decode_packed_array (arr
);
1648 /* If ARR does not represent an array, returns ARR unchanged.
1649 Otherwise, returns a standard GDB array describing ARR (which may
1650 be ARR itself if it already is in the proper form). */
1652 static struct value
*
1653 ada_coerce_to_simple_array (struct value
*arr
)
1655 if (ada_is_array_descriptor_type (value_type (arr
)))
1657 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1659 error (_("Bounds unavailable for null array pointer."));
1660 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1661 return value_ind (arrVal
);
1663 else if (ada_is_packed_array_type (value_type (arr
)))
1664 return decode_packed_array (arr
);
1669 /* If TYPE represents a GNAT array type, return it translated to an
1670 ordinary GDB array type (possibly with BITSIZE fields indicating
1671 packing). For other types, is the identity. */
1674 ada_coerce_to_simple_array_type (struct type
*type
)
1676 struct value
*mark
= value_mark ();
1677 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1678 struct type
*result
;
1679 deprecated_set_value_type (dummy
, type
);
1680 result
= ada_type_of_array (dummy
, 0);
1681 value_free_to_mark (mark
);
1685 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1688 ada_is_packed_array_type (struct type
*type
)
1692 type
= desc_base_type (type
);
1693 type
= ada_check_typedef (type
);
1695 ada_type_name (type
) != NULL
1696 && strstr (ada_type_name (type
), "___XP") != NULL
;
1699 /* Given that TYPE is a standard GDB array type with all bounds filled
1700 in, and that the element size of its ultimate scalar constituents
1701 (that is, either its elements, or, if it is an array of arrays, its
1702 elements' elements, etc.) is *ELT_BITS, return an identical type,
1703 but with the bit sizes of its elements (and those of any
1704 constituent arrays) recorded in the BITSIZE components of its
1705 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1708 static struct type
*
1709 packed_array_type (struct type
*type
, long *elt_bits
)
1711 struct type
*new_elt_type
;
1712 struct type
*new_type
;
1713 LONGEST low_bound
, high_bound
;
1715 type
= ada_check_typedef (type
);
1716 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1719 new_type
= alloc_type (TYPE_OBJFILE (type
));
1720 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1722 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1723 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1724 TYPE_NAME (new_type
) = ada_type_name (type
);
1726 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1727 &low_bound
, &high_bound
) < 0)
1728 low_bound
= high_bound
= 0;
1729 if (high_bound
< low_bound
)
1730 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1733 *elt_bits
*= (high_bound
- low_bound
+ 1);
1734 TYPE_LENGTH (new_type
) =
1735 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1738 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1742 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1744 static struct type
*
1745 decode_packed_array_type (struct type
*type
)
1748 struct block
**blocks
;
1749 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1750 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1751 char *tail
= strstr (raw_name
, "___XP");
1752 struct type
*shadow_type
;
1756 type
= desc_base_type (type
);
1758 memcpy (name
, raw_name
, tail
- raw_name
);
1759 name
[tail
- raw_name
] = '\000';
1761 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1762 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1764 lim_warning (_("could not find bounds information on packed array"));
1767 shadow_type
= SYMBOL_TYPE (sym
);
1769 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1771 lim_warning (_("could not understand bounds information on packed array"));
1775 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1778 (_("could not understand bit size information on packed array"));
1782 return packed_array_type (shadow_type
, &bits
);
1785 /* Given that ARR is a struct value *indicating a GNAT packed array,
1786 returns a simple array that denotes that array. Its type is a
1787 standard GDB array type except that the BITSIZEs of the array
1788 target types are set to the number of bits in each element, and the
1789 type length is set appropriately. */
1791 static struct value
*
1792 decode_packed_array (struct value
*arr
)
1796 arr
= ada_coerce_ref (arr
);
1797 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1798 arr
= ada_value_ind (arr
);
1800 type
= decode_packed_array_type (value_type (arr
));
1803 error (_("can't unpack array"));
1807 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (value_type (arr
)))
1809 /* This is a (right-justified) modular type representing a packed
1810 array with no wrapper. In order to interpret the value through
1811 the (left-justified) packed array type we just built, we must
1812 first left-justify it. */
1813 int bit_size
, bit_pos
;
1816 mod
= ada_modulus (value_type (arr
)) - 1;
1823 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1824 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1825 bit_pos
/ HOST_CHAR_BIT
,
1826 bit_pos
% HOST_CHAR_BIT
,
1831 return coerce_unspec_val_to_type (arr
, type
);
1835 /* The value of the element of packed array ARR at the ARITY indices
1836 given in IND. ARR must be a simple array. */
1838 static struct value
*
1839 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1842 int bits
, elt_off
, bit_off
;
1843 long elt_total_bit_offset
;
1844 struct type
*elt_type
;
1848 elt_total_bit_offset
= 0;
1849 elt_type
= ada_check_typedef (value_type (arr
));
1850 for (i
= 0; i
< arity
; i
+= 1)
1852 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1853 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1855 (_("attempt to do packed indexing of something other than a packed array"));
1858 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1859 LONGEST lowerbound
, upperbound
;
1862 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1864 lim_warning (_("don't know bounds of array"));
1865 lowerbound
= upperbound
= 0;
1868 idx
= value_as_long (value_pos_atr (ind
[i
]));
1869 if (idx
< lowerbound
|| idx
> upperbound
)
1870 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1871 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1872 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1873 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1876 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1877 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1879 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1884 /* Non-zero iff TYPE includes negative integer values. */
1887 has_negatives (struct type
*type
)
1889 switch (TYPE_CODE (type
))
1894 return !TYPE_UNSIGNED (type
);
1895 case TYPE_CODE_RANGE
:
1896 return TYPE_LOW_BOUND (type
) < 0;
1901 /* Create a new value of type TYPE from the contents of OBJ starting
1902 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1903 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1904 assigning through the result will set the field fetched from.
1905 VALADDR is ignored unless OBJ is NULL, in which case,
1906 VALADDR+OFFSET must address the start of storage containing the
1907 packed value. The value returned in this case is never an lval.
1908 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1911 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1912 long offset
, int bit_offset
, int bit_size
,
1916 int src
, /* Index into the source area */
1917 targ
, /* Index into the target area */
1918 srcBitsLeft
, /* Number of source bits left to move */
1919 nsrc
, ntarg
, /* Number of source and target bytes */
1920 unusedLS
, /* Number of bits in next significant
1921 byte of source that are unused */
1922 accumSize
; /* Number of meaningful bits in accum */
1923 unsigned char *bytes
; /* First byte containing data to unpack */
1924 unsigned char *unpacked
;
1925 unsigned long accum
; /* Staging area for bits being transferred */
1927 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1928 /* Transmit bytes from least to most significant; delta is the direction
1929 the indices move. */
1930 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1932 type
= ada_check_typedef (type
);
1936 v
= allocate_value (type
);
1937 bytes
= (unsigned char *) (valaddr
+ offset
);
1939 else if (value_lazy (obj
))
1942 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
1943 bytes
= (unsigned char *) alloca (len
);
1944 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1948 v
= allocate_value (type
);
1949 bytes
= (unsigned char *) value_contents (obj
) + offset
;
1954 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1955 if (VALUE_LVAL (obj
) == lval_internalvar
)
1956 VALUE_LVAL (v
) = lval_internalvar_component
;
1957 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
1958 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
1959 set_value_bitsize (v
, bit_size
);
1960 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
1962 VALUE_ADDRESS (v
) += 1;
1963 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
1967 set_value_bitsize (v
, bit_size
);
1968 unpacked
= (unsigned char *) value_contents (v
);
1970 srcBitsLeft
= bit_size
;
1972 ntarg
= TYPE_LENGTH (type
);
1976 memset (unpacked
, 0, TYPE_LENGTH (type
));
1979 else if (BITS_BIG_ENDIAN
)
1982 if (has_negatives (type
)
1983 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1987 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1990 switch (TYPE_CODE (type
))
1992 case TYPE_CODE_ARRAY
:
1993 case TYPE_CODE_UNION
:
1994 case TYPE_CODE_STRUCT
:
1995 /* Non-scalar values must be aligned at a byte boundary... */
1997 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1998 /* ... And are placed at the beginning (most-significant) bytes
2000 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2004 targ
= TYPE_LENGTH (type
) - 1;
2010 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2013 unusedLS
= bit_offset
;
2016 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2023 /* Mask for removing bits of the next source byte that are not
2024 part of the value. */
2025 unsigned int unusedMSMask
=
2026 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2028 /* Sign-extend bits for this byte. */
2029 unsigned int signMask
= sign
& ~unusedMSMask
;
2031 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2032 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2033 if (accumSize
>= HOST_CHAR_BIT
)
2035 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2036 accumSize
-= HOST_CHAR_BIT
;
2037 accum
>>= HOST_CHAR_BIT
;
2041 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2048 accum
|= sign
<< accumSize
;
2049 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2050 accumSize
-= HOST_CHAR_BIT
;
2051 accum
>>= HOST_CHAR_BIT
;
2059 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2060 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2063 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2064 int src_offset
, int n
)
2066 unsigned int accum
, mask
;
2067 int accum_bits
, chunk_size
;
2069 target
+= targ_offset
/ HOST_CHAR_BIT
;
2070 targ_offset
%= HOST_CHAR_BIT
;
2071 source
+= src_offset
/ HOST_CHAR_BIT
;
2072 src_offset
%= HOST_CHAR_BIT
;
2073 if (BITS_BIG_ENDIAN
)
2075 accum
= (unsigned char) *source
;
2077 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2082 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2083 accum_bits
+= HOST_CHAR_BIT
;
2085 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2088 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2089 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2092 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2094 accum_bits
-= chunk_size
;
2101 accum
= (unsigned char) *source
>> src_offset
;
2103 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2107 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2108 accum_bits
+= HOST_CHAR_BIT
;
2110 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2113 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2114 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2116 accum_bits
-= chunk_size
;
2117 accum
>>= chunk_size
;
2124 /* Store the contents of FROMVAL into the location of TOVAL.
2125 Return a new value with the location of TOVAL and contents of
2126 FROMVAL. Handles assignment into packed fields that have
2127 floating-point or non-scalar types. */
2129 static struct value
*
2130 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2132 struct type
*type
= value_type (toval
);
2133 int bits
= value_bitsize (toval
);
2135 toval
= ada_coerce_ref (toval
);
2136 fromval
= ada_coerce_ref (fromval
);
2138 if (ada_is_direct_array_type (value_type (toval
)))
2139 toval
= ada_coerce_to_simple_array (toval
);
2140 if (ada_is_direct_array_type (value_type (fromval
)))
2141 fromval
= ada_coerce_to_simple_array (fromval
);
2143 if (!deprecated_value_modifiable (toval
))
2144 error (_("Left operand of assignment is not a modifiable lvalue."));
2146 if (VALUE_LVAL (toval
) == lval_memory
2148 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2149 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2151 int len
= (value_bitpos (toval
)
2152 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2153 char *buffer
= (char *) alloca (len
);
2155 CORE_ADDR to_addr
= VALUE_ADDRESS (toval
) + value_offset (toval
);
2157 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2158 fromval
= value_cast (type
, fromval
);
2160 read_memory (to_addr
, buffer
, len
);
2161 if (BITS_BIG_ENDIAN
)
2162 move_bits (buffer
, value_bitpos (toval
),
2163 value_contents (fromval
),
2164 TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
-
2167 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2169 write_memory (to_addr
, buffer
, len
);
2170 if (deprecated_memory_changed_hook
)
2171 deprecated_memory_changed_hook (to_addr
, len
);
2173 val
= value_copy (toval
);
2174 memcpy (value_contents_raw (val
), value_contents (fromval
),
2175 TYPE_LENGTH (type
));
2176 deprecated_set_value_type (val
, type
);
2181 return value_assign (toval
, fromval
);
2185 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2186 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2187 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2188 * COMPONENT, and not the inferior's memory. The current contents
2189 * of COMPONENT are ignored. */
2191 value_assign_to_component (struct value
*container
, struct value
*component
,
2194 LONGEST offset_in_container
=
2195 (LONGEST
) (VALUE_ADDRESS (component
) + value_offset (component
)
2196 - VALUE_ADDRESS (container
) - value_offset (container
));
2197 int bit_offset_in_container
=
2198 value_bitpos (component
) - value_bitpos (container
);
2201 val
= value_cast (value_type (component
), val
);
2203 if (value_bitsize (component
) == 0)
2204 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2206 bits
= value_bitsize (component
);
2208 if (BITS_BIG_ENDIAN
)
2209 move_bits (value_contents_writeable (container
) + offset_in_container
,
2210 value_bitpos (container
) + bit_offset_in_container
,
2211 value_contents (val
),
2212 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2215 move_bits (value_contents_writeable (container
) + offset_in_container
,
2216 value_bitpos (container
) + bit_offset_in_container
,
2217 value_contents (val
), 0, bits
);
2220 /* The value of the element of array ARR at the ARITY indices given in IND.
2221 ARR may be either a simple array, GNAT array descriptor, or pointer
2225 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2229 struct type
*elt_type
;
2231 elt
= ada_coerce_to_simple_array (arr
);
2233 elt_type
= ada_check_typedef (value_type (elt
));
2234 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2235 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2236 return value_subscript_packed (elt
, arity
, ind
);
2238 for (k
= 0; k
< arity
; k
+= 1)
2240 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2241 error (_("too many subscripts (%d expected)"), k
);
2242 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2247 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2248 value of the element of *ARR at the ARITY indices given in
2249 IND. Does not read the entire array into memory. */
2252 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2257 for (k
= 0; k
< arity
; k
+= 1)
2262 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2263 error (_("too many subscripts (%d expected)"), k
);
2264 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2266 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2267 idx
= value_pos_atr (ind
[k
]);
2269 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2270 arr
= value_add (arr
, idx
);
2271 type
= TYPE_TARGET_TYPE (type
);
2274 return value_ind (arr
);
2277 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2278 actual type of ARRAY_PTR is ignored), returns a reference to
2279 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2280 bound of this array is LOW, as per Ada rules. */
2281 static struct value
*
2282 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2285 CORE_ADDR base
= value_as_address (array_ptr
)
2286 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2287 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2288 struct type
*index_type
=
2289 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2291 struct type
*slice_type
=
2292 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2293 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2297 static struct value
*
2298 ada_value_slice (struct value
*array
, int low
, int high
)
2300 struct type
*type
= value_type (array
);
2301 struct type
*index_type
=
2302 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2303 struct type
*slice_type
=
2304 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2305 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2308 /* If type is a record type in the form of a standard GNAT array
2309 descriptor, returns the number of dimensions for type. If arr is a
2310 simple array, returns the number of "array of"s that prefix its
2311 type designation. Otherwise, returns 0. */
2314 ada_array_arity (struct type
*type
)
2321 type
= desc_base_type (type
);
2324 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2325 return desc_arity (desc_bounds_type (type
));
2327 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2330 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2336 /* If TYPE is a record type in the form of a standard GNAT array
2337 descriptor or a simple array type, returns the element type for
2338 TYPE after indexing by NINDICES indices, or by all indices if
2339 NINDICES is -1. Otherwise, returns NULL. */
2342 ada_array_element_type (struct type
*type
, int nindices
)
2344 type
= desc_base_type (type
);
2346 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2349 struct type
*p_array_type
;
2351 p_array_type
= desc_data_type (type
);
2353 k
= ada_array_arity (type
);
2357 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2358 if (nindices
>= 0 && k
> nindices
)
2360 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2361 while (k
> 0 && p_array_type
!= NULL
)
2363 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2366 return p_array_type
;
2368 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2370 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2372 type
= TYPE_TARGET_TYPE (type
);
2381 /* The type of nth index in arrays of given type (n numbering from 1).
2382 Does not examine memory. */
2385 ada_index_type (struct type
*type
, int n
)
2387 struct type
*result_type
;
2389 type
= desc_base_type (type
);
2391 if (n
> ada_array_arity (type
))
2394 if (ada_is_simple_array_type (type
))
2398 for (i
= 1; i
< n
; i
+= 1)
2399 type
= TYPE_TARGET_TYPE (type
);
2400 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2401 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2402 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2403 perhaps stabsread.c would make more sense. */
2404 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2405 result_type
= builtin_type_int
;
2410 return desc_index_type (desc_bounds_type (type
), n
);
2413 /* Given that arr is an array type, returns the lower bound of the
2414 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2415 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2416 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2417 bounds type. It works for other arrays with bounds supplied by
2418 run-time quantities other than discriminants. */
2421 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2422 struct type
** typep
)
2425 struct type
*index_type_desc
;
2427 if (ada_is_packed_array_type (arr_type
))
2428 arr_type
= decode_packed_array_type (arr_type
);
2430 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2433 *typep
= builtin_type_int
;
2434 return (LONGEST
) - which
;
2437 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2438 type
= TYPE_TARGET_TYPE (arr_type
);
2442 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2443 if (index_type_desc
== NULL
)
2445 struct type
*range_type
;
2446 struct type
*index_type
;
2450 type
= TYPE_TARGET_TYPE (type
);
2454 range_type
= TYPE_INDEX_TYPE (type
);
2455 index_type
= TYPE_TARGET_TYPE (range_type
);
2456 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2457 index_type
= builtin_type_long
;
2459 *typep
= index_type
;
2461 (LONGEST
) (which
== 0
2462 ? TYPE_LOW_BOUND (range_type
)
2463 : TYPE_HIGH_BOUND (range_type
));
2467 struct type
*index_type
=
2468 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2469 NULL
, TYPE_OBJFILE (arr_type
));
2471 *typep
= TYPE_TARGET_TYPE (index_type
);
2473 (LONGEST
) (which
== 0
2474 ? TYPE_LOW_BOUND (index_type
)
2475 : TYPE_HIGH_BOUND (index_type
));
2479 /* Given that arr is an array value, returns the lower bound of the
2480 nth index (numbering from 1) if which is 0, and the upper bound if
2481 which is 1. This routine will also work for arrays with bounds
2482 supplied by run-time quantities other than discriminants. */
2485 ada_array_bound (struct value
*arr
, int n
, int which
)
2487 struct type
*arr_type
= value_type (arr
);
2489 if (ada_is_packed_array_type (arr_type
))
2490 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2491 else if (ada_is_simple_array_type (arr_type
))
2494 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2495 return value_from_longest (type
, v
);
2498 return desc_one_bound (desc_bounds (arr
), n
, which
);
2501 /* Given that arr is an array value, returns the length of the
2502 nth index. This routine will also work for arrays with bounds
2503 supplied by run-time quantities other than discriminants.
2504 Does not work for arrays indexed by enumeration types with representation
2505 clauses at the moment. */
2508 ada_array_length (struct value
*arr
, int n
)
2510 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2512 if (ada_is_packed_array_type (arr_type
))
2513 return ada_array_length (decode_packed_array (arr
), n
);
2515 if (ada_is_simple_array_type (arr_type
))
2519 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2520 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2521 return value_from_longest (type
, v
);
2525 value_from_longest (builtin_type_int
,
2526 value_as_long (desc_one_bound (desc_bounds (arr
),
2528 - value_as_long (desc_one_bound (desc_bounds (arr
),
2532 /* An empty array whose type is that of ARR_TYPE (an array type),
2533 with bounds LOW to LOW-1. */
2535 static struct value
*
2536 empty_array (struct type
*arr_type
, int low
)
2538 struct type
*index_type
=
2539 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2541 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2542 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2546 /* Name resolution */
2548 /* The "decoded" name for the user-definable Ada operator corresponding
2552 ada_decoded_op_name (enum exp_opcode op
)
2556 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2558 if (ada_opname_table
[i
].op
== op
)
2559 return ada_opname_table
[i
].decoded
;
2561 error (_("Could not find operator name for opcode"));
2565 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2566 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2567 undefined namespace) and converts operators that are
2568 user-defined into appropriate function calls. If CONTEXT_TYPE is
2569 non-null, it provides a preferred result type [at the moment, only
2570 type void has any effect---causing procedures to be preferred over
2571 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2572 return type is preferred. May change (expand) *EXP. */
2575 resolve (struct expression
**expp
, int void_context_p
)
2579 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2582 /* Resolve the operator of the subexpression beginning at
2583 position *POS of *EXPP. "Resolving" consists of replacing
2584 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2585 with their resolutions, replacing built-in operators with
2586 function calls to user-defined operators, where appropriate, and,
2587 when DEPROCEDURE_P is non-zero, converting function-valued variables
2588 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2589 are as in ada_resolve, above. */
2591 static struct value
*
2592 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2593 struct type
*context_type
)
2597 struct expression
*exp
; /* Convenience: == *expp. */
2598 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2599 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2600 int nargs
; /* Number of operands. */
2607 /* Pass one: resolve operands, saving their types and updating *pos,
2612 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2613 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2618 resolve_subexp (expp
, pos
, 0, NULL
);
2620 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2625 resolve_subexp (expp
, pos
, 0, NULL
);
2630 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2633 case OP_ATR_MODULUS
:
2643 case TERNOP_IN_RANGE
:
2644 case BINOP_IN_BOUNDS
:
2650 case OP_DISCRETE_RANGE
:
2652 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2661 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2663 resolve_subexp (expp
, pos
, 1, NULL
);
2665 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2682 case BINOP_LOGICAL_AND
:
2683 case BINOP_LOGICAL_OR
:
2684 case BINOP_BITWISE_AND
:
2685 case BINOP_BITWISE_IOR
:
2686 case BINOP_BITWISE_XOR
:
2689 case BINOP_NOTEQUAL
:
2696 case BINOP_SUBSCRIPT
:
2704 case UNOP_LOGICAL_NOT
:
2720 case OP_INTERNALVAR
:
2730 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2733 case STRUCTOP_STRUCT
:
2734 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2747 error (_("Unexpected operator during name resolution"));
2750 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2751 for (i
= 0; i
< nargs
; i
+= 1)
2752 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2756 /* Pass two: perform any resolution on principal operator. */
2763 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2765 struct ada_symbol_info
*candidates
;
2769 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2770 (exp
->elts
[pc
+ 2].symbol
),
2771 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2774 if (n_candidates
> 1)
2776 /* Types tend to get re-introduced locally, so if there
2777 are any local symbols that are not types, first filter
2780 for (j
= 0; j
< n_candidates
; j
+= 1)
2781 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2787 case LOC_REGPARM_ADDR
:
2791 case LOC_BASEREG_ARG
:
2793 case LOC_COMPUTED_ARG
:
2799 if (j
< n_candidates
)
2802 while (j
< n_candidates
)
2804 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2806 candidates
[j
] = candidates
[n_candidates
- 1];
2815 if (n_candidates
== 0)
2816 error (_("No definition found for %s"),
2817 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2818 else if (n_candidates
== 1)
2820 else if (deprocedure_p
2821 && !is_nonfunction (candidates
, n_candidates
))
2823 i
= ada_resolve_function
2824 (candidates
, n_candidates
, NULL
, 0,
2825 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2828 error (_("Could not find a match for %s"),
2829 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2833 printf_filtered (_("Multiple matches for %s\n"),
2834 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2835 user_select_syms (candidates
, n_candidates
, 1);
2839 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2840 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2841 if (innermost_block
== NULL
2842 || contained_in (candidates
[i
].block
, innermost_block
))
2843 innermost_block
= candidates
[i
].block
;
2847 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2850 replace_operator_with_call (expp
, pc
, 0, 0,
2851 exp
->elts
[pc
+ 2].symbol
,
2852 exp
->elts
[pc
+ 1].block
);
2859 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2860 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2862 struct ada_symbol_info
*candidates
;
2866 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2867 (exp
->elts
[pc
+ 5].symbol
),
2868 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2870 if (n_candidates
== 1)
2874 i
= ada_resolve_function
2875 (candidates
, n_candidates
,
2877 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2880 error (_("Could not find a match for %s"),
2881 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2884 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2885 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2886 if (innermost_block
== NULL
2887 || contained_in (candidates
[i
].block
, innermost_block
))
2888 innermost_block
= candidates
[i
].block
;
2899 case BINOP_BITWISE_AND
:
2900 case BINOP_BITWISE_IOR
:
2901 case BINOP_BITWISE_XOR
:
2903 case BINOP_NOTEQUAL
:
2911 case UNOP_LOGICAL_NOT
:
2913 if (possible_user_operator_p (op
, argvec
))
2915 struct ada_symbol_info
*candidates
;
2919 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2920 (struct block
*) NULL
, VAR_DOMAIN
,
2922 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2923 ada_decoded_op_name (op
), NULL
);
2927 replace_operator_with_call (expp
, pc
, nargs
, 1,
2928 candidates
[i
].sym
, candidates
[i
].block
);
2938 return evaluate_subexp_type (exp
, pos
);
2941 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2942 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2943 a non-pointer. A type of 'void' (which is never a valid expression type)
2944 by convention matches anything. */
2945 /* The term "match" here is rather loose. The match is heuristic and
2946 liberal. FIXME: TOO liberal, in fact. */
2949 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2951 ftype
= ada_check_typedef (ftype
);
2952 atype
= ada_check_typedef (atype
);
2954 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2955 ftype
= TYPE_TARGET_TYPE (ftype
);
2956 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2957 atype
= TYPE_TARGET_TYPE (atype
);
2959 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2960 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2963 switch (TYPE_CODE (ftype
))
2968 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2969 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2970 TYPE_TARGET_TYPE (atype
), 0);
2973 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2975 case TYPE_CODE_ENUM
:
2976 case TYPE_CODE_RANGE
:
2977 switch (TYPE_CODE (atype
))
2980 case TYPE_CODE_ENUM
:
2981 case TYPE_CODE_RANGE
:
2987 case TYPE_CODE_ARRAY
:
2988 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2989 || ada_is_array_descriptor_type (atype
));
2991 case TYPE_CODE_STRUCT
:
2992 if (ada_is_array_descriptor_type (ftype
))
2993 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2994 || ada_is_array_descriptor_type (atype
));
2996 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2997 && !ada_is_array_descriptor_type (atype
));
2999 case TYPE_CODE_UNION
:
3001 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3005 /* Return non-zero if the formals of FUNC "sufficiently match" the
3006 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3007 may also be an enumeral, in which case it is treated as a 0-
3008 argument function. */
3011 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3014 struct type
*func_type
= SYMBOL_TYPE (func
);
3016 if (SYMBOL_CLASS (func
) == LOC_CONST
3017 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3018 return (n_actuals
== 0);
3019 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3022 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3025 for (i
= 0; i
< n_actuals
; i
+= 1)
3027 if (actuals
[i
] == NULL
)
3031 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
3032 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3034 if (!ada_type_match (ftype
, atype
, 1))
3041 /* False iff function type FUNC_TYPE definitely does not produce a value
3042 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3043 FUNC_TYPE is not a valid function type with a non-null return type
3044 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3047 return_match (struct type
*func_type
, struct type
*context_type
)
3049 struct type
*return_type
;
3051 if (func_type
== NULL
)
3054 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3055 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3057 return_type
= base_type (func_type
);
3058 if (return_type
== NULL
)
3061 context_type
= base_type (context_type
);
3063 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3064 return context_type
== NULL
|| return_type
== context_type
;
3065 else if (context_type
== NULL
)
3066 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3068 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3072 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3073 function (if any) that matches the types of the NARGS arguments in
3074 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3075 that returns that type, then eliminate matches that don't. If
3076 CONTEXT_TYPE is void and there is at least one match that does not
3077 return void, eliminate all matches that do.
3079 Asks the user if there is more than one match remaining. Returns -1
3080 if there is no such symbol or none is selected. NAME is used
3081 solely for messages. May re-arrange and modify SYMS in
3082 the process; the index returned is for the modified vector. */
3085 ada_resolve_function (struct ada_symbol_info syms
[],
3086 int nsyms
, struct value
**args
, int nargs
,
3087 const char *name
, struct type
*context_type
)
3090 int m
; /* Number of hits */
3091 struct type
*fallback
;
3092 struct type
*return_type
;
3094 return_type
= context_type
;
3095 if (context_type
== NULL
)
3096 fallback
= builtin_type_void
;
3103 for (k
= 0; k
< nsyms
; k
+= 1)
3105 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3107 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3108 && return_match (type
, return_type
))
3114 if (m
> 0 || return_type
== fallback
)
3117 return_type
= fallback
;
3124 printf_filtered (_("Multiple matches for %s\n"), name
);
3125 user_select_syms (syms
, m
, 1);
3131 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3132 in a listing of choices during disambiguation (see sort_choices, below).
3133 The idea is that overloadings of a subprogram name from the
3134 same package should sort in their source order. We settle for ordering
3135 such symbols by their trailing number (__N or $N). */
3138 encoded_ordered_before (char *N0
, char *N1
)
3142 else if (N0
== NULL
)
3147 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3149 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3151 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3152 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3156 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3159 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3161 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3162 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3164 return (strcmp (N0
, N1
) < 0);
3168 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3172 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3175 for (i
= 1; i
< nsyms
; i
+= 1)
3177 struct ada_symbol_info sym
= syms
[i
];
3180 for (j
= i
- 1; j
>= 0; j
-= 1)
3182 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3183 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3185 syms
[j
+ 1] = syms
[j
];
3191 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3192 by asking the user (if necessary), returning the number selected,
3193 and setting the first elements of SYMS items. Error if no symbols
3196 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3197 to be re-integrated one of these days. */
3200 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3203 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3205 int first_choice
= (max_results
== 1) ? 1 : 2;
3207 if (max_results
< 1)
3208 error (_("Request to select 0 symbols!"));
3212 printf_unfiltered (_("[0] cancel\n"));
3213 if (max_results
> 1)
3214 printf_unfiltered (_("[1] all\n"));
3216 sort_choices (syms
, nsyms
);
3218 for (i
= 0; i
< nsyms
; i
+= 1)
3220 if (syms
[i
].sym
== NULL
)
3223 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3225 struct symtab_and_line sal
=
3226 find_function_start_sal (syms
[i
].sym
, 1);
3227 if (sal
.symtab
== NULL
)
3228 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3230 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3233 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3234 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3235 sal
.symtab
->filename
, sal
.line
);
3241 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3242 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3243 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3244 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3246 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3247 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3249 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3250 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3251 else if (is_enumeral
3252 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3254 printf_unfiltered (("[%d] "), i
+ first_choice
);
3255 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3257 printf_unfiltered (_("'(%s) (enumeral)\n"),
3258 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3260 else if (symtab
!= NULL
)
3261 printf_unfiltered (is_enumeral
3262 ? _("[%d] %s in %s (enumeral)\n")
3263 : _("[%d] %s at %s:?\n"),
3265 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3268 printf_unfiltered (is_enumeral
3269 ? _("[%d] %s (enumeral)\n")
3270 : _("[%d] %s at ?\n"),
3272 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3276 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3279 for (i
= 0; i
< n_chosen
; i
+= 1)
3280 syms
[i
] = syms
[chosen
[i
]];
3285 /* Read and validate a set of numeric choices from the user in the
3286 range 0 .. N_CHOICES-1. Place the results in increasing
3287 order in CHOICES[0 .. N-1], and return N.
3289 The user types choices as a sequence of numbers on one line
3290 separated by blanks, encoding them as follows:
3292 + A choice of 0 means to cancel the selection, throwing an error.
3293 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3294 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3296 The user is not allowed to choose more than MAX_RESULTS values.
3298 ANNOTATION_SUFFIX, if present, is used to annotate the input
3299 prompts (for use with the -f switch). */
3302 get_selections (int *choices
, int n_choices
, int max_results
,
3303 int is_all_choice
, char *annotation_suffix
)
3308 int first_choice
= is_all_choice
? 2 : 1;
3310 prompt
= getenv ("PS2");
3314 printf_unfiltered (("%s "), prompt
);
3315 gdb_flush (gdb_stdout
);
3317 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3320 error_no_arg (_("one or more choice numbers"));
3324 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3325 order, as given in args. Choices are validated. */
3331 while (isspace (*args
))
3333 if (*args
== '\0' && n_chosen
== 0)
3334 error_no_arg (_("one or more choice numbers"));
3335 else if (*args
== '\0')
3338 choice
= strtol (args
, &args2
, 10);
3339 if (args
== args2
|| choice
< 0
3340 || choice
> n_choices
+ first_choice
- 1)
3341 error (_("Argument must be choice number"));
3345 error (_("cancelled"));
3347 if (choice
< first_choice
)
3349 n_chosen
= n_choices
;
3350 for (j
= 0; j
< n_choices
; j
+= 1)
3354 choice
-= first_choice
;
3356 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3360 if (j
< 0 || choice
!= choices
[j
])
3363 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3364 choices
[k
+ 1] = choices
[k
];
3365 choices
[j
+ 1] = choice
;
3370 if (n_chosen
> max_results
)
3371 error (_("Select no more than %d of the above"), max_results
);
3376 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3377 on the function identified by SYM and BLOCK, and taking NARGS
3378 arguments. Update *EXPP as needed to hold more space. */
3381 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3382 int oplen
, struct symbol
*sym
,
3383 struct block
*block
)
3385 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3386 symbol, -oplen for operator being replaced). */
3387 struct expression
*newexp
= (struct expression
*)
3388 xmalloc (sizeof (struct expression
)
3389 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3390 struct expression
*exp
= *expp
;
3392 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3393 newexp
->language_defn
= exp
->language_defn
;
3394 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3395 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3396 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3398 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3399 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3401 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3402 newexp
->elts
[pc
+ 4].block
= block
;
3403 newexp
->elts
[pc
+ 5].symbol
= sym
;
3409 /* Type-class predicates */
3411 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3415 numeric_type_p (struct type
*type
)
3421 switch (TYPE_CODE (type
))
3426 case TYPE_CODE_RANGE
:
3427 return (type
== TYPE_TARGET_TYPE (type
)
3428 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3435 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3438 integer_type_p (struct type
*type
)
3444 switch (TYPE_CODE (type
))
3448 case TYPE_CODE_RANGE
:
3449 return (type
== TYPE_TARGET_TYPE (type
)
3450 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3457 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3460 scalar_type_p (struct type
*type
)
3466 switch (TYPE_CODE (type
))
3469 case TYPE_CODE_RANGE
:
3470 case TYPE_CODE_ENUM
:
3479 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3482 discrete_type_p (struct type
*type
)
3488 switch (TYPE_CODE (type
))
3491 case TYPE_CODE_RANGE
:
3492 case TYPE_CODE_ENUM
:
3500 /* Returns non-zero if OP with operands in the vector ARGS could be
3501 a user-defined function. Errs on the side of pre-defined operators
3502 (i.e., result 0). */
3505 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3507 struct type
*type0
=
3508 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3509 struct type
*type1
=
3510 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3524 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3528 case BINOP_BITWISE_AND
:
3529 case BINOP_BITWISE_IOR
:
3530 case BINOP_BITWISE_XOR
:
3531 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3534 case BINOP_NOTEQUAL
:
3539 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3542 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3545 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3549 case UNOP_LOGICAL_NOT
:
3551 return (!numeric_type_p (type0
));
3560 1. In the following, we assume that a renaming type's name may
3561 have an ___XD suffix. It would be nice if this went away at some
3563 2. We handle both the (old) purely type-based representation of
3564 renamings and the (new) variable-based encoding. At some point,
3565 it is devoutly to be hoped that the former goes away
3566 (FIXME: hilfinger-2007-07-09).
3567 3. Subprogram renamings are not implemented, although the XRS
3568 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3570 /* If SYM encodes a renaming,
3572 <renaming> renames <renamed entity>,
3574 sets *LEN to the length of the renamed entity's name,
3575 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3576 the string describing the subcomponent selected from the renamed
3577 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3578 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3579 are undefined). Otherwise, returns a value indicating the category
3580 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3581 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3582 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3583 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3584 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3585 may be NULL, in which case they are not assigned.
3587 [Currently, however, GCC does not generate subprogram renamings.] */
3589 enum ada_renaming_category
3590 ada_parse_renaming (struct symbol
*sym
,
3591 const char **renamed_entity
, int *len
,
3592 const char **renaming_expr
)
3594 enum ada_renaming_category kind
;
3599 return ADA_NOT_RENAMING
;
3600 switch (SYMBOL_CLASS (sym
))
3603 return ADA_NOT_RENAMING
;
3605 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3606 renamed_entity
, len
, renaming_expr
);
3610 case LOC_OPTIMIZED_OUT
:
3611 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3613 return ADA_NOT_RENAMING
;
3617 kind
= ADA_OBJECT_RENAMING
;
3621 kind
= ADA_EXCEPTION_RENAMING
;
3625 kind
= ADA_PACKAGE_RENAMING
;
3629 kind
= ADA_SUBPROGRAM_RENAMING
;
3633 return ADA_NOT_RENAMING
;
3637 if (renamed_entity
!= NULL
)
3638 *renamed_entity
= info
;
3639 suffix
= strstr (info
, "___XE");
3640 if (suffix
== NULL
|| suffix
== info
)
3641 return ADA_NOT_RENAMING
;
3643 *len
= strlen (info
) - strlen (suffix
);
3645 if (renaming_expr
!= NULL
)
3646 *renaming_expr
= suffix
;
3650 /* Assuming TYPE encodes a renaming according to the old encoding in
3651 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3652 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3653 ADA_NOT_RENAMING otherwise. */
3654 static enum ada_renaming_category
3655 parse_old_style_renaming (struct type
*type
,
3656 const char **renamed_entity
, int *len
,
3657 const char **renaming_expr
)
3659 enum ada_renaming_category kind
;
3664 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3665 || TYPE_NFIELDS (type
) != 1)
3666 return ADA_NOT_RENAMING
;
3668 name
= type_name_no_tag (type
);
3670 return ADA_NOT_RENAMING
;
3672 name
= strstr (name
, "___XR");
3674 return ADA_NOT_RENAMING
;
3679 kind
= ADA_OBJECT_RENAMING
;
3682 kind
= ADA_EXCEPTION_RENAMING
;
3685 kind
= ADA_PACKAGE_RENAMING
;
3688 kind
= ADA_SUBPROGRAM_RENAMING
;
3691 return ADA_NOT_RENAMING
;
3694 info
= TYPE_FIELD_NAME (type
, 0);
3696 return ADA_NOT_RENAMING
;
3697 if (renamed_entity
!= NULL
)
3698 *renamed_entity
= info
;
3699 suffix
= strstr (info
, "___XE");
3700 if (renaming_expr
!= NULL
)
3701 *renaming_expr
= suffix
+ 5;
3702 if (suffix
== NULL
|| suffix
== info
)
3703 return ADA_NOT_RENAMING
;
3705 *len
= suffix
- info
;
3711 /* Evaluation: Function Calls */
3713 /* Return an lvalue containing the value VAL. This is the identity on
3714 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3715 on the stack, using and updating *SP as the stack pointer, and
3716 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3718 static struct value
*
3719 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3721 if (! VALUE_LVAL (val
))
3723 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3725 /* The following is taken from the structure-return code in
3726 call_function_by_hand. FIXME: Therefore, some refactoring seems
3728 if (gdbarch_inner_than (current_gdbarch
, 1, 2))
3730 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3731 reserving sufficient space. */
3733 if (gdbarch_frame_align_p (current_gdbarch
))
3734 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3735 VALUE_ADDRESS (val
) = *sp
;
3739 /* Stack grows upward. Align the frame, allocate space, and
3740 then again, re-align the frame. */
3741 if (gdbarch_frame_align_p (current_gdbarch
))
3742 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3743 VALUE_ADDRESS (val
) = *sp
;
3745 if (gdbarch_frame_align_p (current_gdbarch
))
3746 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3749 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3755 /* Return the value ACTUAL, converted to be an appropriate value for a
3756 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3757 allocating any necessary descriptors (fat pointers), or copies of
3758 values not residing in memory, updating it as needed. */
3760 static struct value
*
3761 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3764 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3765 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3766 struct type
*formal_target
=
3767 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3768 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3769 struct type
*actual_target
=
3770 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3771 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3773 if (ada_is_array_descriptor_type (formal_target
)
3774 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3775 return make_array_descriptor (formal_type
, actual
, sp
);
3776 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3778 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3779 && ada_is_array_descriptor_type (actual_target
))
3780 return desc_data (actual
);
3781 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3783 if (VALUE_LVAL (actual
) != lval_memory
)
3786 actual_type
= ada_check_typedef (value_type (actual
));
3787 val
= allocate_value (actual_type
);
3788 memcpy ((char *) value_contents_raw (val
),
3789 (char *) value_contents (actual
),
3790 TYPE_LENGTH (actual_type
));
3791 actual
= ensure_lval (val
, sp
);
3793 return value_addr (actual
);
3796 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3797 return ada_value_ind (actual
);
3803 /* Push a descriptor of type TYPE for array value ARR on the stack at
3804 *SP, updating *SP to reflect the new descriptor. Return either
3805 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3806 to-descriptor type rather than a descriptor type), a struct value *
3807 representing a pointer to this descriptor. */
3809 static struct value
*
3810 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3812 struct type
*bounds_type
= desc_bounds_type (type
);
3813 struct type
*desc_type
= desc_base_type (type
);
3814 struct value
*descriptor
= allocate_value (desc_type
);
3815 struct value
*bounds
= allocate_value (bounds_type
);
3818 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3820 modify_general_field (value_contents_writeable (bounds
),
3821 value_as_long (ada_array_bound (arr
, i
, 0)),
3822 desc_bound_bitpos (bounds_type
, i
, 0),
3823 desc_bound_bitsize (bounds_type
, i
, 0));
3824 modify_general_field (value_contents_writeable (bounds
),
3825 value_as_long (ada_array_bound (arr
, i
, 1)),
3826 desc_bound_bitpos (bounds_type
, i
, 1),
3827 desc_bound_bitsize (bounds_type
, i
, 1));
3830 bounds
= ensure_lval (bounds
, sp
);
3832 modify_general_field (value_contents_writeable (descriptor
),
3833 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3834 fat_pntr_data_bitpos (desc_type
),
3835 fat_pntr_data_bitsize (desc_type
));
3837 modify_general_field (value_contents_writeable (descriptor
),
3838 VALUE_ADDRESS (bounds
),
3839 fat_pntr_bounds_bitpos (desc_type
),
3840 fat_pntr_bounds_bitsize (desc_type
));
3842 descriptor
= ensure_lval (descriptor
, sp
);
3844 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3845 return value_addr (descriptor
);
3851 /* Assuming a dummy frame has been established on the target, perform any
3852 conversions needed for calling function FUNC on the NARGS actual
3853 parameters in ARGS, other than standard C conversions. Does
3854 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3855 does not match the number of arguments expected. Use *SP as a
3856 stack pointer for additional data that must be pushed, updating its
3860 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3865 if (TYPE_NFIELDS (value_type (func
)) == 0
3866 || nargs
!= TYPE_NFIELDS (value_type (func
)))
3869 for (i
= 0; i
< nargs
; i
+= 1)
3871 convert_actual (args
[i
], TYPE_FIELD_TYPE (value_type (func
), i
), sp
);
3874 /* Dummy definitions for an experimental caching module that is not
3875 * used in the public sources. */
3878 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3879 struct symbol
**sym
, struct block
**block
,
3880 struct symtab
**symtab
)
3886 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3887 struct block
*block
, struct symtab
*symtab
)
3893 /* Return the result of a standard (literal, C-like) lookup of NAME in
3894 given DOMAIN, visible from lexical block BLOCK. */
3896 static struct symbol
*
3897 standard_lookup (const char *name
, const struct block
*block
,
3901 struct symtab
*symtab
;
3903 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3906 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3907 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3912 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3913 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3914 since they contend in overloading in the same way. */
3916 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3920 for (i
= 0; i
< n
; i
+= 1)
3921 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3922 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3923 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3929 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3930 struct types. Otherwise, they may not. */
3933 equiv_types (struct type
*type0
, struct type
*type1
)
3937 if (type0
== NULL
|| type1
== NULL
3938 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3940 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3941 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3942 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3943 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3949 /* True iff SYM0 represents the same entity as SYM1, or one that is
3950 no more defined than that of SYM1. */
3953 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3957 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3958 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3961 switch (SYMBOL_CLASS (sym0
))
3967 struct type
*type0
= SYMBOL_TYPE (sym0
);
3968 struct type
*type1
= SYMBOL_TYPE (sym1
);
3969 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3970 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3971 int len0
= strlen (name0
);
3973 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3974 && (equiv_types (type0
, type1
)
3975 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3976 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3979 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3980 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3986 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3987 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3990 add_defn_to_vec (struct obstack
*obstackp
,
3992 struct block
*block
, struct symtab
*symtab
)
3996 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3998 /* Do not try to complete stub types, as the debugger is probably
3999 already scanning all symbols matching a certain name at the
4000 time when this function is called. Trying to replace the stub
4001 type by its associated full type will cause us to restart a scan
4002 which may lead to an infinite recursion. Instead, the client
4003 collecting the matching symbols will end up collecting several
4004 matches, with at least one of them complete. It can then filter
4005 out the stub ones if needed. */
4007 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4009 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4011 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4013 prevDefns
[i
].sym
= sym
;
4014 prevDefns
[i
].block
= block
;
4015 prevDefns
[i
].symtab
= symtab
;
4021 struct ada_symbol_info info
;
4025 info
.symtab
= symtab
;
4026 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4030 /* Number of ada_symbol_info structures currently collected in
4031 current vector in *OBSTACKP. */
4034 num_defns_collected (struct obstack
*obstackp
)
4036 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4039 /* Vector of ada_symbol_info structures currently collected in current
4040 vector in *OBSTACKP. If FINISH, close off the vector and return
4041 its final address. */
4043 static struct ada_symbol_info
*
4044 defns_collected (struct obstack
*obstackp
, int finish
)
4047 return obstack_finish (obstackp
);
4049 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4052 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4053 Check the global symbols if GLOBAL, the static symbols if not.
4054 Do wild-card match if WILD. */
4056 static struct partial_symbol
*
4057 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
4058 int global
, domain_enum
namespace, int wild
)
4060 struct partial_symbol
**start
;
4061 int name_len
= strlen (name
);
4062 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
4071 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
4072 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
4076 for (i
= 0; i
< length
; i
+= 1)
4078 struct partial_symbol
*psym
= start
[i
];
4080 if (SYMBOL_DOMAIN (psym
) == namespace
4081 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
4095 int M
= (U
+ i
) >> 1;
4096 struct partial_symbol
*psym
= start
[M
];
4097 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
4099 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
4101 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4112 struct partial_symbol
*psym
= start
[i
];
4114 if (SYMBOL_DOMAIN (psym
) == namespace)
4116 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4124 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4138 int M
= (U
+ i
) >> 1;
4139 struct partial_symbol
*psym
= start
[M
];
4140 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4142 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4144 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4155 struct partial_symbol
*psym
= start
[i
];
4157 if (SYMBOL_DOMAIN (psym
) == namespace)
4161 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4164 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4166 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4176 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4186 /* Find a symbol table containing symbol SYM or NULL if none. */
4188 static struct symtab
*
4189 symtab_for_sym (struct symbol
*sym
)
4192 struct objfile
*objfile
;
4194 struct symbol
*tmp_sym
;
4195 struct dict_iterator iter
;
4198 ALL_PRIMARY_SYMTABS (objfile
, s
)
4200 switch (SYMBOL_CLASS (sym
))
4208 case LOC_CONST_BYTES
:
4209 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4210 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4212 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4213 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4219 switch (SYMBOL_CLASS (sym
))
4225 case LOC_REGPARM_ADDR
:
4230 case LOC_BASEREG_ARG
:
4232 case LOC_COMPUTED_ARG
:
4233 for (j
= FIRST_LOCAL_BLOCK
;
4234 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4236 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4237 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4248 /* Return a minimal symbol matching NAME according to Ada decoding
4249 rules. Returns NULL if there is no such minimal symbol. Names
4250 prefixed with "standard__" are handled specially: "standard__" is
4251 first stripped off, and only static and global symbols are searched. */
4253 struct minimal_symbol
*
4254 ada_lookup_simple_minsym (const char *name
)
4256 struct objfile
*objfile
;
4257 struct minimal_symbol
*msymbol
;
4260 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4262 name
+= sizeof ("standard__") - 1;
4266 wild_match
= (strstr (name
, "__") == NULL
);
4268 ALL_MSYMBOLS (objfile
, msymbol
)
4270 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4271 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4278 /* For all subprograms that statically enclose the subprogram of the
4279 selected frame, add symbols matching identifier NAME in DOMAIN
4280 and their blocks to the list of data in OBSTACKP, as for
4281 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4285 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4286 const char *name
, domain_enum
namespace,
4291 /* True if TYPE is definitely an artificial type supplied to a symbol
4292 for which no debugging information was given in the symbol file. */
4295 is_nondebugging_type (struct type
*type
)
4297 char *name
= ada_type_name (type
);
4298 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4301 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4302 duplicate other symbols in the list (The only case I know of where
4303 this happens is when object files containing stabs-in-ecoff are
4304 linked with files containing ordinary ecoff debugging symbols (or no
4305 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4306 Returns the number of items in the modified list. */
4309 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4316 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4317 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4318 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4320 for (j
= 0; j
< nsyms
; j
+= 1)
4323 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4324 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4325 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4326 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4327 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4328 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4331 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4332 syms
[k
- 1] = syms
[k
];
4345 /* Given a type that corresponds to a renaming entity, use the type name
4346 to extract the scope (package name or function name, fully qualified,
4347 and following the GNAT encoding convention) where this renaming has been
4348 defined. The string returned needs to be deallocated after use. */
4351 xget_renaming_scope (struct type
*renaming_type
)
4353 /* The renaming types adhere to the following convention:
4354 <scope>__<rename>___<XR extension>.
4355 So, to extract the scope, we search for the "___XR" extension,
4356 and then backtrack until we find the first "__". */
4358 const char *name
= type_name_no_tag (renaming_type
);
4359 char *suffix
= strstr (name
, "___XR");
4364 /* Now, backtrack a bit until we find the first "__". Start looking
4365 at suffix - 3, as the <rename> part is at least one character long. */
4367 for (last
= suffix
- 3; last
> name
; last
--)
4368 if (last
[0] == '_' && last
[1] == '_')
4371 /* Make a copy of scope and return it. */
4373 scope_len
= last
- name
;
4374 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4376 strncpy (scope
, name
, scope_len
);
4377 scope
[scope_len
] = '\0';
4382 /* Return nonzero if NAME corresponds to a package name. */
4385 is_package_name (const char *name
)
4387 /* Here, We take advantage of the fact that no symbols are generated
4388 for packages, while symbols are generated for each function.
4389 So the condition for NAME represent a package becomes equivalent
4390 to NAME not existing in our list of symbols. There is only one
4391 small complication with library-level functions (see below). */
4395 /* If it is a function that has not been defined at library level,
4396 then we should be able to look it up in the symbols. */
4397 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4400 /* Library-level function names start with "_ada_". See if function
4401 "_ada_" followed by NAME can be found. */
4403 /* Do a quick check that NAME does not contain "__", since library-level
4404 functions names cannot contain "__" in them. */
4405 if (strstr (name
, "__") != NULL
)
4408 fun_name
= xstrprintf ("_ada_%s", name
);
4410 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4413 /* Return nonzero if SYM corresponds to a renaming entity that is
4414 not visible from FUNCTION_NAME. */
4417 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4421 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4424 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4426 make_cleanup (xfree
, scope
);
4428 /* If the rename has been defined in a package, then it is visible. */
4429 if (is_package_name (scope
))
4432 /* Check that the rename is in the current function scope by checking
4433 that its name starts with SCOPE. */
4435 /* If the function name starts with "_ada_", it means that it is
4436 a library-level function. Strip this prefix before doing the
4437 comparison, as the encoding for the renaming does not contain
4439 if (strncmp (function_name
, "_ada_", 5) == 0)
4442 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4445 /* Remove entries from SYMS that corresponds to a renaming entity that
4446 is not visible from the function associated with CURRENT_BLOCK or
4447 that is superfluous due to the presence of more specific renaming
4448 information. Places surviving symbols in the initial entries of
4449 SYMS and returns the number of surviving symbols.
4452 First, in cases where an object renaming is implemented as a
4453 reference variable, GNAT may produce both the actual reference
4454 variable and the renaming encoding. In this case, we discard the
4457 Second, GNAT emits a type following a specified encoding for each renaming
4458 entity. Unfortunately, STABS currently does not support the definition
4459 of types that are local to a given lexical block, so all renamings types
4460 are emitted at library level. As a consequence, if an application
4461 contains two renaming entities using the same name, and a user tries to
4462 print the value of one of these entities, the result of the ada symbol
4463 lookup will also contain the wrong renaming type.
4465 This function partially covers for this limitation by attempting to
4466 remove from the SYMS list renaming symbols that should be visible
4467 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4468 method with the current information available. The implementation
4469 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4471 - When the user tries to print a rename in a function while there
4472 is another rename entity defined in a package: Normally, the
4473 rename in the function has precedence over the rename in the
4474 package, so the latter should be removed from the list. This is
4475 currently not the case.
4477 - This function will incorrectly remove valid renames if
4478 the CURRENT_BLOCK corresponds to a function which symbol name
4479 has been changed by an "Export" pragma. As a consequence,
4480 the user will be unable to print such rename entities. */
4483 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4484 int nsyms
, const struct block
*current_block
)
4486 struct symbol
*current_function
;
4487 char *current_function_name
;
4489 int is_new_style_renaming
;
4491 /* If there is both a renaming foo___XR... encoded as a variable and
4492 a simple variable foo in the same block, discard the latter.
4493 First, zero out such symbols, then compress. */
4494 is_new_style_renaming
= 0;
4495 for (i
= 0; i
< nsyms
; i
+= 1)
4497 struct symbol
*sym
= syms
[i
].sym
;
4498 struct block
*block
= syms
[i
].block
;
4502 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4504 name
= SYMBOL_LINKAGE_NAME (sym
);
4505 suffix
= strstr (name
, "___XR");
4509 int name_len
= suffix
- name
;
4511 is_new_style_renaming
= 1;
4512 for (j
= 0; j
< nsyms
; j
+= 1)
4513 if (i
!= j
&& syms
[j
].sym
!= NULL
4514 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4516 && block
== syms
[j
].block
)
4520 if (is_new_style_renaming
)
4524 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4525 if (syms
[j
].sym
!= NULL
)
4533 /* Extract the function name associated to CURRENT_BLOCK.
4534 Abort if unable to do so. */
4536 if (current_block
== NULL
)
4539 current_function
= block_function (current_block
);
4540 if (current_function
== NULL
)
4543 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4544 if (current_function_name
== NULL
)
4547 /* Check each of the symbols, and remove it from the list if it is
4548 a type corresponding to a renaming that is out of the scope of
4549 the current block. */
4554 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4555 == ADA_OBJECT_RENAMING
4556 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4559 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4560 syms
[j
- 1] = syms
[j
];
4570 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4571 scope and in global scopes, returning the number of matches. Sets
4572 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4573 indicating the symbols found and the blocks and symbol tables (if
4574 any) in which they were found. This vector are transient---good only to
4575 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4576 symbol match within the nest of blocks whose innermost member is BLOCK0,
4577 is the one match returned (no other matches in that or
4578 enclosing blocks is returned). If there are any matches in or
4579 surrounding BLOCK0, then these alone are returned. Otherwise, the
4580 search extends to global and file-scope (static) symbol tables.
4581 Names prefixed with "standard__" are handled specially: "standard__"
4582 is first stripped off, and only static and global symbols are searched. */
4585 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4586 domain_enum
namespace,
4587 struct ada_symbol_info
**results
)
4591 struct partial_symtab
*ps
;
4592 struct blockvector
*bv
;
4593 struct objfile
*objfile
;
4594 struct block
*block
;
4596 struct minimal_symbol
*msymbol
;
4602 obstack_free (&symbol_list_obstack
, NULL
);
4603 obstack_init (&symbol_list_obstack
);
4607 /* Search specified block and its superiors. */
4609 wild_match
= (strstr (name0
, "__") == NULL
);
4611 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4612 needed, but adding const will
4613 have a cascade effect. */
4614 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4618 name
= name0
+ sizeof ("standard__") - 1;
4622 while (block
!= NULL
)
4625 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4626 namespace, NULL
, NULL
, wild_match
);
4628 /* If we found a non-function match, assume that's the one. */
4629 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4630 num_defns_collected (&symbol_list_obstack
)))
4633 block
= BLOCK_SUPERBLOCK (block
);
4636 /* If no luck so far, try to find NAME as a local symbol in some lexically
4637 enclosing subprogram. */
4638 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4639 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4640 name
, namespace, wild_match
);
4642 /* If we found ANY matches among non-global symbols, we're done. */
4644 if (num_defns_collected (&symbol_list_obstack
) > 0)
4648 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4651 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4655 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4656 tables, and psymtab's. */
4658 ALL_PRIMARY_SYMTABS (objfile
, s
)
4661 bv
= BLOCKVECTOR (s
);
4662 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4663 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4664 objfile
, s
, wild_match
);
4667 if (namespace == VAR_DOMAIN
)
4669 ALL_MSYMBOLS (objfile
, msymbol
)
4671 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4673 switch (MSYMBOL_TYPE (msymbol
))
4675 case mst_solib_trampoline
:
4678 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4681 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4683 bv
= BLOCKVECTOR (s
);
4684 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4685 ada_add_block_symbols (&symbol_list_obstack
, block
,
4686 SYMBOL_LINKAGE_NAME (msymbol
),
4687 namespace, objfile
, s
, wild_match
);
4689 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4691 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4692 ada_add_block_symbols (&symbol_list_obstack
, block
,
4693 SYMBOL_LINKAGE_NAME (msymbol
),
4694 namespace, objfile
, s
,
4703 ALL_PSYMTABS (objfile
, ps
)
4707 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4709 s
= PSYMTAB_TO_SYMTAB (ps
);
4712 bv
= BLOCKVECTOR (s
);
4713 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4714 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4715 namespace, objfile
, s
, wild_match
);
4719 /* Now add symbols from all per-file blocks if we've gotten no hits
4720 (Not strictly correct, but perhaps better than an error).
4721 Do the symtabs first, then check the psymtabs. */
4723 if (num_defns_collected (&symbol_list_obstack
) == 0)
4726 ALL_PRIMARY_SYMTABS (objfile
, s
)
4729 bv
= BLOCKVECTOR (s
);
4730 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4731 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4732 objfile
, s
, wild_match
);
4735 ALL_PSYMTABS (objfile
, ps
)
4739 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4741 s
= PSYMTAB_TO_SYMTAB (ps
);
4742 bv
= BLOCKVECTOR (s
);
4745 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4746 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4747 namespace, objfile
, s
, wild_match
);
4753 ndefns
= num_defns_collected (&symbol_list_obstack
);
4754 *results
= defns_collected (&symbol_list_obstack
, 1);
4756 ndefns
= remove_extra_symbols (*results
, ndefns
);
4759 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4761 if (ndefns
== 1 && cacheIfUnique
)
4762 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4763 (*results
)[0].symtab
);
4765 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4771 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4772 domain_enum
namespace,
4773 struct block
**block_found
, struct symtab
**symtab
)
4775 struct ada_symbol_info
*candidates
;
4778 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4780 if (n_candidates
== 0)
4783 if (block_found
!= NULL
)
4784 *block_found
= candidates
[0].block
;
4788 *symtab
= candidates
[0].symtab
;
4789 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4791 struct objfile
*objfile
;
4794 struct blockvector
*bv
;
4796 /* Search the list of symtabs for one which contains the
4797 address of the start of this block. */
4798 ALL_PRIMARY_SYMTABS (objfile
, s
)
4800 bv
= BLOCKVECTOR (s
);
4801 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4802 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4803 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4806 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4809 /* FIXME: brobecker/2004-11-12: I think that we should never
4810 reach this point. I don't see a reason why we would not
4811 find a symtab for a given block, so I suggest raising an
4812 internal_error exception here. Otherwise, we end up
4813 returning a symbol but no symtab, which certain parts of
4814 the code that rely (indirectly) on this function do not
4815 expect, eventually causing a SEGV. */
4816 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4819 return candidates
[0].sym
;
4822 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4823 scope and in global scopes, or NULL if none. NAME is folded and
4824 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4825 choosing the first symbol if there are multiple choices.
4826 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4827 table in which the symbol was found (in both cases, these
4828 assignments occur only if the pointers are non-null). */
4830 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4831 domain_enum
namespace, int *is_a_field_of_this
,
4832 struct symtab
**symtab
)
4834 if (is_a_field_of_this
!= NULL
)
4835 *is_a_field_of_this
= 0;
4838 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4839 block0
, namespace, NULL
, symtab
);
4842 static struct symbol
*
4843 ada_lookup_symbol_nonlocal (const char *name
,
4844 const char *linkage_name
,
4845 const struct block
*block
,
4846 const domain_enum domain
, struct symtab
**symtab
)
4848 if (linkage_name
== NULL
)
4849 linkage_name
= name
;
4850 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4855 /* True iff STR is a possible encoded suffix of a normal Ada name
4856 that is to be ignored for matching purposes. Suffixes of parallel
4857 names (e.g., XVE) are not included here. Currently, the possible suffixes
4858 are given by either of the regular expression:
4860 (__[0-9]+)?[.$][0-9]+ [nested subprogram suffix, on platforms such
4862 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4863 _E[0-9]+[bs]$ [protected object entry suffixes]
4864 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4868 is_name_suffix (const char *str
)
4871 const char *matching
;
4872 const int len
= strlen (str
);
4874 /* (__[0-9]+)?\.[0-9]+ */
4876 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4879 while (isdigit (matching
[0]))
4881 if (matching
[0] == '\0')
4885 if (matching
[0] == '.' || matching
[0] == '$')
4888 while (isdigit (matching
[0]))
4890 if (matching
[0] == '\0')
4895 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4898 while (isdigit (matching
[0]))
4900 if (matching
[0] == '\0')
4905 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4906 with a N at the end. Unfortunately, the compiler uses the same
4907 convention for other internal types it creates. So treating
4908 all entity names that end with an "N" as a name suffix causes
4909 some regressions. For instance, consider the case of an enumerated
4910 type. To support the 'Image attribute, it creates an array whose
4912 Having a single character like this as a suffix carrying some
4913 information is a bit risky. Perhaps we should change the encoding
4914 to be something like "_N" instead. In the meantime, do not do
4915 the following check. */
4916 /* Protected Object Subprograms */
4917 if (len
== 1 && str
[0] == 'N')
4922 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4925 while (isdigit (matching
[0]))
4927 if ((matching
[0] == 'b' || matching
[0] == 's')
4928 && matching
[1] == '\0')
4932 /* ??? We should not modify STR directly, as we are doing below. This
4933 is fine in this case, but may become problematic later if we find
4934 that this alternative did not work, and want to try matching
4935 another one from the begining of STR. Since we modified it, we
4936 won't be able to find the begining of the string anymore! */
4940 while (str
[0] != '_' && str
[0] != '\0')
4942 if (str
[0] != 'n' && str
[0] != 'b')
4947 if (str
[0] == '\000')
4951 if (str
[1] != '_' || str
[2] == '\000')
4955 if (strcmp (str
+ 3, "JM") == 0)
4957 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4958 the LJM suffix in favor of the JM one. But we will
4959 still accept LJM as a valid suffix for a reasonable
4960 amount of time, just to allow ourselves to debug programs
4961 compiled using an older version of GNAT. */
4962 if (strcmp (str
+ 3, "LJM") == 0)
4966 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4967 || str
[4] == 'U' || str
[4] == 'P')
4969 if (str
[4] == 'R' && str
[5] != 'T')
4973 if (!isdigit (str
[2]))
4975 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4976 if (!isdigit (str
[k
]) && str
[k
] != '_')
4980 if (str
[0] == '$' && isdigit (str
[1]))
4982 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4983 if (!isdigit (str
[k
]) && str
[k
] != '_')
4990 /* Return nonzero if the given string starts with a dot ('.')
4991 followed by zero or more digits.
4993 Note: brobecker/2003-11-10: A forward declaration has not been
4994 added at the begining of this file yet, because this function
4995 is only used to work around a problem found during wild matching
4996 when trying to match minimal symbol names against symbol names
4997 obtained from dwarf-2 data. This function is therefore currently
4998 only used in wild_match() and is likely to be deleted when the
4999 problem in dwarf-2 is fixed. */
5002 is_dot_digits_suffix (const char *str
)
5008 while (isdigit (str
[0]))
5010 return (str
[0] == '\0');
5013 /* Return non-zero if the string starting at NAME and ending before
5014 NAME_END contains no capital letters. */
5017 is_valid_name_for_wild_match (const char *name0
)
5019 const char *decoded_name
= ada_decode (name0
);
5022 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5023 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5029 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5030 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5031 informational suffixes of NAME (i.e., for which is_name_suffix is
5035 wild_match (const char *patn0
, int patn_len
, const char *name0
)
5042 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
5043 stored in the symbol table for nested function names is sometimes
5044 different from the name of the associated entity stored in
5045 the dwarf-2 data: This is the case for nested subprograms, where
5046 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
5047 while the symbol name from the dwarf-2 data does not.
5049 Although the DWARF-2 standard documents that entity names stored
5050 in the dwarf-2 data should be identical to the name as seen in
5051 the source code, GNAT takes a different approach as we already use
5052 a special encoding mechanism to convey the information so that
5053 a C debugger can still use the information generated to debug
5054 Ada programs. A corollary is that the symbol names in the dwarf-2
5055 data should match the names found in the symbol table. I therefore
5056 consider this issue as a compiler defect.
5058 Until the compiler is properly fixed, we work-around the problem
5059 by ignoring such suffixes during the match. We do so by making
5060 a copy of PATN0 and NAME0, and then by stripping such a suffix
5061 if present. We then perform the match on the resulting strings. */
5064 name_len
= strlen (name0
);
5066 name
= name_start
= (char *) alloca ((name_len
+ 1) * sizeof (char));
5067 strcpy (name
, name0
);
5068 dot
= strrchr (name
, '.');
5069 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
5072 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
5073 strncpy (patn
, patn0
, patn_len
);
5074 patn
[patn_len
] = '\0';
5075 dot
= strrchr (patn
, '.');
5076 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
5079 patn_len
= dot
- patn
;
5083 /* Now perform the wild match. */
5085 name_len
= strlen (name
);
5086 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
5087 && strncmp (patn
, name
+ 5, patn_len
) == 0
5088 && is_name_suffix (name
+ patn_len
+ 5))
5091 while (name_len
>= patn_len
)
5093 if (strncmp (patn
, name
, patn_len
) == 0
5094 && is_name_suffix (name
+ patn_len
))
5095 return (name
== name_start
|| is_valid_name_for_wild_match (name0
));
5102 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
5107 if (!islower (name
[2]))
5114 if (!islower (name
[1]))
5125 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5126 vector *defn_symbols, updating the list of symbols in OBSTACKP
5127 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5128 OBJFILE is the section containing BLOCK.
5129 SYMTAB is recorded with each symbol added. */
5132 ada_add_block_symbols (struct obstack
*obstackp
,
5133 struct block
*block
, const char *name
,
5134 domain_enum domain
, struct objfile
*objfile
,
5135 struct symtab
*symtab
, int wild
)
5137 struct dict_iterator iter
;
5138 int name_len
= strlen (name
);
5139 /* A matching argument symbol, if any. */
5140 struct symbol
*arg_sym
;
5141 /* Set true when we find a matching non-argument symbol. */
5150 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5152 if (SYMBOL_DOMAIN (sym
) == domain
5153 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5155 switch (SYMBOL_CLASS (sym
))
5161 case LOC_REGPARM_ADDR
:
5162 case LOC_BASEREG_ARG
:
5163 case LOC_COMPUTED_ARG
:
5166 case LOC_UNRESOLVED
:
5170 add_defn_to_vec (obstackp
,
5171 fixup_symbol_section (sym
, objfile
),
5180 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5182 if (SYMBOL_DOMAIN (sym
) == domain
)
5184 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5186 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5188 switch (SYMBOL_CLASS (sym
))
5194 case LOC_REGPARM_ADDR
:
5195 case LOC_BASEREG_ARG
:
5196 case LOC_COMPUTED_ARG
:
5199 case LOC_UNRESOLVED
:
5203 add_defn_to_vec (obstackp
,
5204 fixup_symbol_section (sym
, objfile
),
5213 if (!found_sym
&& arg_sym
!= NULL
)
5215 add_defn_to_vec (obstackp
,
5216 fixup_symbol_section (arg_sym
, objfile
),
5225 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5227 if (SYMBOL_DOMAIN (sym
) == domain
)
5231 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5234 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5236 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5241 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5243 switch (SYMBOL_CLASS (sym
))
5249 case LOC_REGPARM_ADDR
:
5250 case LOC_BASEREG_ARG
:
5251 case LOC_COMPUTED_ARG
:
5254 case LOC_UNRESOLVED
:
5258 add_defn_to_vec (obstackp
,
5259 fixup_symbol_section (sym
, objfile
),
5267 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5268 They aren't parameters, right? */
5269 if (!found_sym
&& arg_sym
!= NULL
)
5271 add_defn_to_vec (obstackp
,
5272 fixup_symbol_section (arg_sym
, objfile
),
5280 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5281 for tagged types. */
5284 ada_is_dispatch_table_ptr_type (struct type
*type
)
5288 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5291 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5295 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5298 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5299 to be invisible to users. */
5302 ada_is_ignored_field (struct type
*type
, int field_num
)
5304 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5307 /* Check the name of that field. */
5309 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5311 /* Anonymous field names should not be printed.
5312 brobecker/2007-02-20: I don't think this can actually happen
5313 but we don't want to print the value of annonymous fields anyway. */
5317 /* A field named "_parent" is internally generated by GNAT for
5318 tagged types, and should not be printed either. */
5319 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5323 /* If this is the dispatch table of a tagged type, then ignore. */
5324 if (ada_is_tagged_type (type
, 1)
5325 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5328 /* Not a special field, so it should not be ignored. */
5332 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5333 pointer or reference type whose ultimate target has a tag field. */
5336 ada_is_tagged_type (struct type
*type
, int refok
)
5338 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5341 /* True iff TYPE represents the type of X'Tag */
5344 ada_is_tag_type (struct type
*type
)
5346 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5350 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5351 return (name
!= NULL
5352 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5356 /* The type of the tag on VAL. */
5359 ada_tag_type (struct value
*val
)
5361 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5364 /* The value of the tag on VAL. */
5367 ada_value_tag (struct value
*val
)
5369 return ada_value_struct_elt (val
, "_tag", 0);
5372 /* The value of the tag on the object of type TYPE whose contents are
5373 saved at VALADDR, if it is non-null, or is at memory address
5376 static struct value
*
5377 value_tag_from_contents_and_address (struct type
*type
,
5378 const gdb_byte
*valaddr
,
5381 int tag_byte_offset
, dummy1
, dummy2
;
5382 struct type
*tag_type
;
5383 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5386 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5388 : valaddr
+ tag_byte_offset
);
5389 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5391 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5396 static struct type
*
5397 type_from_tag (struct value
*tag
)
5399 const char *type_name
= ada_tag_name (tag
);
5400 if (type_name
!= NULL
)
5401 return ada_find_any_type (ada_encode (type_name
));
5412 static int ada_tag_name_1 (void *);
5413 static int ada_tag_name_2 (struct tag_args
*);
5415 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5416 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5417 The value stored in ARGS->name is valid until the next call to
5421 ada_tag_name_1 (void *args0
)
5423 struct tag_args
*args
= (struct tag_args
*) args0
;
5424 static char name
[1024];
5428 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5430 return ada_tag_name_2 (args
);
5431 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5434 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5435 for (p
= name
; *p
!= '\0'; p
+= 1)
5442 /* Utility function for ada_tag_name_1 that tries the second
5443 representation for the dispatch table (in which there is no
5444 explicit 'tsd' field in the referent of the tag pointer, and instead
5445 the tsd pointer is stored just before the dispatch table. */
5448 ada_tag_name_2 (struct tag_args
*args
)
5450 struct type
*info_type
;
5451 static char name
[1024];
5453 struct value
*val
, *valp
;
5456 info_type
= ada_find_any_type ("ada__tags__type_specific_data");
5457 if (info_type
== NULL
)
5459 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5460 valp
= value_cast (info_type
, args
->tag
);
5463 val
= value_ind (value_add (valp
, value_from_longest (builtin_type_int
, -1)));
5466 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5469 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5470 for (p
= name
; *p
!= '\0'; p
+= 1)
5477 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5481 ada_tag_name (struct value
*tag
)
5483 struct tag_args args
;
5484 if (!ada_is_tag_type (value_type (tag
)))
5488 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5492 /* The parent type of TYPE, or NULL if none. */
5495 ada_parent_type (struct type
*type
)
5499 type
= ada_check_typedef (type
);
5501 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5504 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5505 if (ada_is_parent_field (type
, i
))
5506 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5511 /* True iff field number FIELD_NUM of structure type TYPE contains the
5512 parent-type (inherited) fields of a derived type. Assumes TYPE is
5513 a structure type with at least FIELD_NUM+1 fields. */
5516 ada_is_parent_field (struct type
*type
, int field_num
)
5518 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5519 return (name
!= NULL
5520 && (strncmp (name
, "PARENT", 6) == 0
5521 || strncmp (name
, "_parent", 7) == 0));
5524 /* True iff field number FIELD_NUM of structure type TYPE is a
5525 transparent wrapper field (which should be silently traversed when doing
5526 field selection and flattened when printing). Assumes TYPE is a
5527 structure type with at least FIELD_NUM+1 fields. Such fields are always
5531 ada_is_wrapper_field (struct type
*type
, int field_num
)
5533 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5534 return (name
!= NULL
5535 && (strncmp (name
, "PARENT", 6) == 0
5536 || strcmp (name
, "REP") == 0
5537 || strncmp (name
, "_parent", 7) == 0
5538 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5541 /* True iff field number FIELD_NUM of structure or union type TYPE
5542 is a variant wrapper. Assumes TYPE is a structure type with at least
5543 FIELD_NUM+1 fields. */
5546 ada_is_variant_part (struct type
*type
, int field_num
)
5548 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5549 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5550 || (is_dynamic_field (type
, field_num
)
5551 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5552 == TYPE_CODE_UNION
)));
5555 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5556 whose discriminants are contained in the record type OUTER_TYPE,
5557 returns the type of the controlling discriminant for the variant. */
5560 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5562 char *name
= ada_variant_discrim_name (var_type
);
5564 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5566 return builtin_type_int
;
5571 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5572 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5573 represents a 'when others' clause; otherwise 0. */
5576 ada_is_others_clause (struct type
*type
, int field_num
)
5578 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5579 return (name
!= NULL
&& name
[0] == 'O');
5582 /* Assuming that TYPE0 is the type of the variant part of a record,
5583 returns the name of the discriminant controlling the variant.
5584 The value is valid until the next call to ada_variant_discrim_name. */
5587 ada_variant_discrim_name (struct type
*type0
)
5589 static char *result
= NULL
;
5590 static size_t result_len
= 0;
5593 const char *discrim_end
;
5594 const char *discrim_start
;
5596 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5597 type
= TYPE_TARGET_TYPE (type0
);
5601 name
= ada_type_name (type
);
5603 if (name
== NULL
|| name
[0] == '\000')
5606 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5609 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5612 if (discrim_end
== name
)
5615 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5618 if (discrim_start
== name
+ 1)
5620 if ((discrim_start
> name
+ 3
5621 && strncmp (discrim_start
- 3, "___", 3) == 0)
5622 || discrim_start
[-1] == '.')
5626 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5627 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5628 result
[discrim_end
- discrim_start
] = '\0';
5632 /* Scan STR for a subtype-encoded number, beginning at position K.
5633 Put the position of the character just past the number scanned in
5634 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5635 Return 1 if there was a valid number at the given position, and 0
5636 otherwise. A "subtype-encoded" number consists of the absolute value
5637 in decimal, followed by the letter 'm' to indicate a negative number.
5638 Assumes 0m does not occur. */
5641 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5645 if (!isdigit (str
[k
]))
5648 /* Do it the hard way so as not to make any assumption about
5649 the relationship of unsigned long (%lu scan format code) and
5652 while (isdigit (str
[k
]))
5654 RU
= RU
* 10 + (str
[k
] - '0');
5661 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5667 /* NOTE on the above: Technically, C does not say what the results of
5668 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5669 number representable as a LONGEST (although either would probably work
5670 in most implementations). When RU>0, the locution in the then branch
5671 above is always equivalent to the negative of RU. */
5678 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5679 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5680 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5683 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5685 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5698 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5707 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5708 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5710 if (val
>= L
&& val
<= U
)
5722 /* FIXME: Lots of redundancy below. Try to consolidate. */
5724 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5725 ARG_TYPE, extract and return the value of one of its (non-static)
5726 fields. FIELDNO says which field. Differs from value_primitive_field
5727 only in that it can handle packed values of arbitrary type. */
5729 static struct value
*
5730 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5731 struct type
*arg_type
)
5735 arg_type
= ada_check_typedef (arg_type
);
5736 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5738 /* Handle packed fields. */
5740 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5742 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5743 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5745 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5746 offset
+ bit_pos
/ 8,
5747 bit_pos
% 8, bit_size
, type
);
5750 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5753 /* Find field with name NAME in object of type TYPE. If found,
5754 set the following for each argument that is non-null:
5755 - *FIELD_TYPE_P to the field's type;
5756 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5757 an object of that type;
5758 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5759 - *BIT_SIZE_P to its size in bits if the field is packed, and
5761 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5762 fields up to but not including the desired field, or by the total
5763 number of fields if not found. A NULL value of NAME never
5764 matches; the function just counts visible fields in this case.
5766 Returns 1 if found, 0 otherwise. */
5769 find_struct_field (char *name
, struct type
*type
, int offset
,
5770 struct type
**field_type_p
,
5771 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
5776 type
= ada_check_typedef (type
);
5778 if (field_type_p
!= NULL
)
5779 *field_type_p
= NULL
;
5780 if (byte_offset_p
!= NULL
)
5782 if (bit_offset_p
!= NULL
)
5784 if (bit_size_p
!= NULL
)
5787 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5789 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5790 int fld_offset
= offset
+ bit_pos
/ 8;
5791 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5793 if (t_field_name
== NULL
)
5796 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
5798 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5799 if (field_type_p
!= NULL
)
5800 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5801 if (byte_offset_p
!= NULL
)
5802 *byte_offset_p
= fld_offset
;
5803 if (bit_offset_p
!= NULL
)
5804 *bit_offset_p
= bit_pos
% 8;
5805 if (bit_size_p
!= NULL
)
5806 *bit_size_p
= bit_size
;
5809 else if (ada_is_wrapper_field (type
, i
))
5811 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5812 field_type_p
, byte_offset_p
, bit_offset_p
,
5813 bit_size_p
, index_p
))
5816 else if (ada_is_variant_part (type
, i
))
5818 /* PNH: Wait. Do we ever execute this section, or is ARG always of
5821 struct type
*field_type
5822 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5824 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
5826 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5828 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5829 field_type_p
, byte_offset_p
,
5830 bit_offset_p
, bit_size_p
, index_p
))
5834 else if (index_p
!= NULL
)
5840 /* Number of user-visible fields in record type TYPE. */
5843 num_visible_fields (struct type
*type
)
5847 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
5851 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5852 and search in it assuming it has (class) type TYPE.
5853 If found, return value, else return NULL.
5855 Searches recursively through wrapper fields (e.g., '_parent'). */
5857 static struct value
*
5858 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5862 type
= ada_check_typedef (type
);
5864 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5866 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5868 if (t_field_name
== NULL
)
5871 else if (field_name_match (t_field_name
, name
))
5872 return ada_value_primitive_field (arg
, offset
, i
, type
);
5874 else if (ada_is_wrapper_field (type
, i
))
5876 struct value
*v
= /* Do not let indent join lines here. */
5877 ada_search_struct_field (name
, arg
,
5878 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5879 TYPE_FIELD_TYPE (type
, i
));
5884 else if (ada_is_variant_part (type
, i
))
5886 /* PNH: Do we ever get here? See find_struct_field. */
5888 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5889 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5891 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
5893 struct value
*v
= ada_search_struct_field
/* Force line break. */
5895 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5896 TYPE_FIELD_TYPE (field_type
, j
));
5905 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
5906 int, struct type
*);
5909 /* Return field #INDEX in ARG, where the index is that returned by
5910 * find_struct_field through its INDEX_P argument. Adjust the address
5911 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
5912 * If found, return value, else return NULL. */
5914 static struct value
*
5915 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
5918 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
5922 /* Auxiliary function for ada_index_struct_field. Like
5923 * ada_index_struct_field, but takes index from *INDEX_P and modifies
5926 static struct value
*
5927 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
5931 type
= ada_check_typedef (type
);
5933 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5935 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
5937 else if (ada_is_wrapper_field (type
, i
))
5939 struct value
*v
= /* Do not let indent join lines here. */
5940 ada_index_struct_field_1 (index_p
, arg
,
5941 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5942 TYPE_FIELD_TYPE (type
, i
));
5947 else if (ada_is_variant_part (type
, i
))
5949 /* PNH: Do we ever get here? See ada_search_struct_field,
5950 find_struct_field. */
5951 error (_("Cannot assign this kind of variant record"));
5953 else if (*index_p
== 0)
5954 return ada_value_primitive_field (arg
, offset
, i
, type
);
5961 /* Given ARG, a value of type (pointer or reference to a)*
5962 structure/union, extract the component named NAME from the ultimate
5963 target structure/union and return it as a value with its
5964 appropriate type. If ARG is a pointer or reference and the field
5965 is not packed, returns a reference to the field, otherwise the
5966 value of the field (an lvalue if ARG is an lvalue).
5968 The routine searches for NAME among all members of the structure itself
5969 and (recursively) among all members of any wrapper members
5972 If NO_ERR, then simply return NULL in case of error, rather than
5976 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
5978 struct type
*t
, *t1
;
5982 t1
= t
= ada_check_typedef (value_type (arg
));
5983 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5985 t1
= TYPE_TARGET_TYPE (t
);
5988 t1
= ada_check_typedef (t1
);
5989 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5991 arg
= coerce_ref (arg
);
5996 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5998 t1
= TYPE_TARGET_TYPE (t
);
6001 t1
= ada_check_typedef (t1
);
6002 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6004 arg
= value_ind (arg
);
6011 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6015 v
= ada_search_struct_field (name
, arg
, 0, t
);
6018 int bit_offset
, bit_size
, byte_offset
;
6019 struct type
*field_type
;
6022 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6023 address
= value_as_address (arg
);
6025 address
= unpack_pointer (t
, value_contents (arg
));
6027 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
6028 if (find_struct_field (name
, t1
, 0,
6029 &field_type
, &byte_offset
, &bit_offset
,
6034 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6035 arg
= ada_coerce_ref (arg
);
6037 arg
= ada_value_ind (arg
);
6038 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6039 bit_offset
, bit_size
,
6043 v
= value_from_pointer (lookup_reference_type (field_type
),
6044 address
+ byte_offset
);
6048 if (v
!= NULL
|| no_err
)
6051 error (_("There is no member named %s."), name
);
6057 error (_("Attempt to extract a component of a value that is not a record."));
6060 /* Given a type TYPE, look up the type of the component of type named NAME.
6061 If DISPP is non-null, add its byte displacement from the beginning of a
6062 structure (pointed to by a value) of type TYPE to *DISPP (does not
6063 work for packed fields).
6065 Matches any field whose name has NAME as a prefix, possibly
6068 TYPE can be either a struct or union. If REFOK, TYPE may also
6069 be a (pointer or reference)+ to a struct or union, and the
6070 ultimate target type will be searched.
6072 Looks recursively into variant clauses and parent types.
6074 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6075 TYPE is not a type of the right kind. */
6077 static struct type
*
6078 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6079 int noerr
, int *dispp
)
6086 if (refok
&& type
!= NULL
)
6089 type
= ada_check_typedef (type
);
6090 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6091 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6093 type
= TYPE_TARGET_TYPE (type
);
6097 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6098 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6104 target_terminal_ours ();
6105 gdb_flush (gdb_stdout
);
6107 error (_("Type (null) is not a structure or union type"));
6110 /* XXX: type_sprint */
6111 fprintf_unfiltered (gdb_stderr
, _("Type "));
6112 type_print (type
, "", gdb_stderr
, -1);
6113 error (_(" is not a structure or union type"));
6118 type
= to_static_fixed_type (type
);
6120 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6122 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6126 if (t_field_name
== NULL
)
6129 else if (field_name_match (t_field_name
, name
))
6132 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6133 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6136 else if (ada_is_wrapper_field (type
, i
))
6139 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6144 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6149 else if (ada_is_variant_part (type
, i
))
6152 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6154 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6157 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6162 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6173 target_terminal_ours ();
6174 gdb_flush (gdb_stdout
);
6177 /* XXX: type_sprint */
6178 fprintf_unfiltered (gdb_stderr
, _("Type "));
6179 type_print (type
, "", gdb_stderr
, -1);
6180 error (_(" has no component named <null>"));
6184 /* XXX: type_sprint */
6185 fprintf_unfiltered (gdb_stderr
, _("Type "));
6186 type_print (type
, "", gdb_stderr
, -1);
6187 error (_(" has no component named %s"), name
);
6194 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6195 within a value of type OUTER_TYPE that is stored in GDB at
6196 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6197 numbering from 0) is applicable. Returns -1 if none are. */
6200 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6201 const gdb_byte
*outer_valaddr
)
6206 struct type
*discrim_type
;
6207 char *discrim_name
= ada_variant_discrim_name (var_type
);
6208 LONGEST discrim_val
;
6212 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
6213 if (discrim_type
== NULL
)
6215 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
6218 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6220 if (ada_is_others_clause (var_type
, i
))
6222 else if (ada_in_variant (discrim_val
, var_type
, i
))
6226 return others_clause
;
6231 /* Dynamic-Sized Records */
6233 /* Strategy: The type ostensibly attached to a value with dynamic size
6234 (i.e., a size that is not statically recorded in the debugging
6235 data) does not accurately reflect the size or layout of the value.
6236 Our strategy is to convert these values to values with accurate,
6237 conventional types that are constructed on the fly. */
6239 /* There is a subtle and tricky problem here. In general, we cannot
6240 determine the size of dynamic records without its data. However,
6241 the 'struct value' data structure, which GDB uses to represent
6242 quantities in the inferior process (the target), requires the size
6243 of the type at the time of its allocation in order to reserve space
6244 for GDB's internal copy of the data. That's why the
6245 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6246 rather than struct value*s.
6248 However, GDB's internal history variables ($1, $2, etc.) are
6249 struct value*s containing internal copies of the data that are not, in
6250 general, the same as the data at their corresponding addresses in
6251 the target. Fortunately, the types we give to these values are all
6252 conventional, fixed-size types (as per the strategy described
6253 above), so that we don't usually have to perform the
6254 'to_fixed_xxx_type' conversions to look at their values.
6255 Unfortunately, there is one exception: if one of the internal
6256 history variables is an array whose elements are unconstrained
6257 records, then we will need to create distinct fixed types for each
6258 element selected. */
6260 /* The upshot of all of this is that many routines take a (type, host
6261 address, target address) triple as arguments to represent a value.
6262 The host address, if non-null, is supposed to contain an internal
6263 copy of the relevant data; otherwise, the program is to consult the
6264 target at the target address. */
6266 /* Assuming that VAL0 represents a pointer value, the result of
6267 dereferencing it. Differs from value_ind in its treatment of
6268 dynamic-sized types. */
6271 ada_value_ind (struct value
*val0
)
6273 struct value
*val
= unwrap_value (value_ind (val0
));
6274 return ada_to_fixed_value (val
);
6277 /* The value resulting from dereferencing any "reference to"
6278 qualifiers on VAL0. */
6280 static struct value
*
6281 ada_coerce_ref (struct value
*val0
)
6283 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6285 struct value
*val
= val0
;
6286 val
= coerce_ref (val
);
6287 val
= unwrap_value (val
);
6288 return ada_to_fixed_value (val
);
6294 /* Return OFF rounded upward if necessary to a multiple of
6295 ALIGNMENT (a power of 2). */
6298 align_value (unsigned int off
, unsigned int alignment
)
6300 return (off
+ alignment
- 1) & ~(alignment
- 1);
6303 /* Return the bit alignment required for field #F of template type TYPE. */
6306 field_alignment (struct type
*type
, int f
)
6308 const char *name
= TYPE_FIELD_NAME (type
, f
);
6312 /* The field name should never be null, unless the debugging information
6313 is somehow malformed. In this case, we assume the field does not
6314 require any alignment. */
6318 len
= strlen (name
);
6320 if (!isdigit (name
[len
- 1]))
6323 if (isdigit (name
[len
- 2]))
6324 align_offset
= len
- 2;
6326 align_offset
= len
- 1;
6328 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6329 return TARGET_CHAR_BIT
;
6331 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6334 /* Find a symbol named NAME. Ignores ambiguity. */
6337 ada_find_any_symbol (const char *name
)
6341 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6342 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6345 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6349 /* Find a type named NAME. Ignores ambiguity. */
6352 ada_find_any_type (const char *name
)
6354 struct symbol
*sym
= ada_find_any_symbol (name
);
6357 return SYMBOL_TYPE (sym
);
6362 /* Given NAME and an associated BLOCK, search all symbols for
6363 NAME suffixed with "___XR", which is the ``renaming'' symbol
6364 associated to NAME. Return this symbol if found, return
6368 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6372 sym
= find_old_style_renaming_symbol (name
, block
);
6377 /* Not right yet. FIXME pnh 7/20/2007. */
6378 sym
= ada_find_any_symbol (name
);
6379 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6385 static struct symbol
*
6386 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6388 const struct symbol
*function_sym
= block_function (block
);
6391 if (function_sym
!= NULL
)
6393 /* If the symbol is defined inside a function, NAME is not fully
6394 qualified. This means we need to prepend the function name
6395 as well as adding the ``___XR'' suffix to build the name of
6396 the associated renaming symbol. */
6397 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6398 /* Function names sometimes contain suffixes used
6399 for instance to qualify nested subprograms. When building
6400 the XR type name, we need to make sure that this suffix is
6401 not included. So do not include any suffix in the function
6402 name length below. */
6403 const int function_name_len
= ada_name_prefix_len (function_name
);
6404 const int rename_len
= function_name_len
+ 2 /* "__" */
6405 + strlen (name
) + 6 /* "___XR\0" */ ;
6407 /* Strip the suffix if necessary. */
6408 function_name
[function_name_len
] = '\0';
6410 /* Library-level functions are a special case, as GNAT adds
6411 a ``_ada_'' prefix to the function name to avoid namespace
6412 pollution. However, the renaming symbols themselves do not
6413 have this prefix, so we need to skip this prefix if present. */
6414 if (function_name_len
> 5 /* "_ada_" */
6415 && strstr (function_name
, "_ada_") == function_name
)
6416 function_name
= function_name
+ 5;
6418 rename
= (char *) alloca (rename_len
* sizeof (char));
6419 sprintf (rename
, "%s__%s___XR", function_name
, name
);
6423 const int rename_len
= strlen (name
) + 6;
6424 rename
= (char *) alloca (rename_len
* sizeof (char));
6425 sprintf (rename
, "%s___XR", name
);
6428 return ada_find_any_symbol (rename
);
6431 /* Because of GNAT encoding conventions, several GDB symbols may match a
6432 given type name. If the type denoted by TYPE0 is to be preferred to
6433 that of TYPE1 for purposes of type printing, return non-zero;
6434 otherwise return 0. */
6437 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6441 else if (type0
== NULL
)
6443 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6445 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6447 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6449 else if (ada_is_packed_array_type (type0
))
6451 else if (ada_is_array_descriptor_type (type0
)
6452 && !ada_is_array_descriptor_type (type1
))
6456 const char *type0_name
= type_name_no_tag (type0
);
6457 const char *type1_name
= type_name_no_tag (type1
);
6459 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6460 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6466 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6467 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6470 ada_type_name (struct type
*type
)
6474 else if (TYPE_NAME (type
) != NULL
)
6475 return TYPE_NAME (type
);
6477 return TYPE_TAG_NAME (type
);
6480 /* Find a parallel type to TYPE whose name is formed by appending
6481 SUFFIX to the name of TYPE. */
6484 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6487 static size_t name_len
= 0;
6489 char *typename
= ada_type_name (type
);
6491 if (typename
== NULL
)
6494 len
= strlen (typename
);
6496 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
6498 strcpy (name
, typename
);
6499 strcpy (name
+ len
, suffix
);
6501 return ada_find_any_type (name
);
6505 /* If TYPE is a variable-size record type, return the corresponding template
6506 type describing its fields. Otherwise, return NULL. */
6508 static struct type
*
6509 dynamic_template_type (struct type
*type
)
6511 type
= ada_check_typedef (type
);
6513 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6514 || ada_type_name (type
) == NULL
)
6518 int len
= strlen (ada_type_name (type
));
6519 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6522 return ada_find_parallel_type (type
, "___XVE");
6526 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6527 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6530 is_dynamic_field (struct type
*templ_type
, int field_num
)
6532 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6534 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6535 && strstr (name
, "___XVL") != NULL
;
6538 /* The index of the variant field of TYPE, or -1 if TYPE does not
6539 represent a variant record type. */
6542 variant_field_index (struct type
*type
)
6546 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6549 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6551 if (ada_is_variant_part (type
, f
))
6557 /* A record type with no fields. */
6559 static struct type
*
6560 empty_record (struct objfile
*objfile
)
6562 struct type
*type
= alloc_type (objfile
);
6563 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6564 TYPE_NFIELDS (type
) = 0;
6565 TYPE_FIELDS (type
) = NULL
;
6566 TYPE_NAME (type
) = "<empty>";
6567 TYPE_TAG_NAME (type
) = NULL
;
6568 TYPE_FLAGS (type
) = 0;
6569 TYPE_LENGTH (type
) = 0;
6573 /* An ordinary record type (with fixed-length fields) that describes
6574 the value of type TYPE at VALADDR or ADDRESS (see comments at
6575 the beginning of this section) VAL according to GNAT conventions.
6576 DVAL0 should describe the (portion of a) record that contains any
6577 necessary discriminants. It should be NULL if value_type (VAL) is
6578 an outer-level type (i.e., as opposed to a branch of a variant.) A
6579 variant field (unless unchecked) is replaced by a particular branch
6582 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6583 length are not statically known are discarded. As a consequence,
6584 VALADDR, ADDRESS and DVAL0 are ignored.
6586 NOTE: Limitations: For now, we assume that dynamic fields and
6587 variants occupy whole numbers of bytes. However, they need not be
6591 ada_template_to_fixed_record_type_1 (struct type
*type
,
6592 const gdb_byte
*valaddr
,
6593 CORE_ADDR address
, struct value
*dval0
,
6594 int keep_dynamic_fields
)
6596 struct value
*mark
= value_mark ();
6599 int nfields
, bit_len
;
6602 int fld_bit_len
, bit_incr
;
6605 /* Compute the number of fields in this record type that are going
6606 to be processed: unless keep_dynamic_fields, this includes only
6607 fields whose position and length are static will be processed. */
6608 if (keep_dynamic_fields
)
6609 nfields
= TYPE_NFIELDS (type
);
6613 while (nfields
< TYPE_NFIELDS (type
)
6614 && !ada_is_variant_part (type
, nfields
)
6615 && !is_dynamic_field (type
, nfields
))
6619 rtype
= alloc_type (TYPE_OBJFILE (type
));
6620 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6621 INIT_CPLUS_SPECIFIC (rtype
);
6622 TYPE_NFIELDS (rtype
) = nfields
;
6623 TYPE_FIELDS (rtype
) = (struct field
*)
6624 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6625 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6626 TYPE_NAME (rtype
) = ada_type_name (type
);
6627 TYPE_TAG_NAME (rtype
) = NULL
;
6628 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6634 for (f
= 0; f
< nfields
; f
+= 1)
6636 off
= align_value (off
, field_alignment (type
, f
))
6637 + TYPE_FIELD_BITPOS (type
, f
);
6638 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6639 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6641 if (ada_is_variant_part (type
, f
))
6644 fld_bit_len
= bit_incr
= 0;
6646 else if (is_dynamic_field (type
, f
))
6649 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6653 TYPE_FIELD_TYPE (rtype
, f
) =
6656 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6657 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6658 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6659 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6660 bit_incr
= fld_bit_len
=
6661 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6665 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6666 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6667 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6668 bit_incr
= fld_bit_len
=
6669 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6671 bit_incr
= fld_bit_len
=
6672 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6674 if (off
+ fld_bit_len
> bit_len
)
6675 bit_len
= off
+ fld_bit_len
;
6677 TYPE_LENGTH (rtype
) =
6678 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6681 /* We handle the variant part, if any, at the end because of certain
6682 odd cases in which it is re-ordered so as NOT the last field of
6683 the record. This can happen in the presence of representation
6685 if (variant_field
>= 0)
6687 struct type
*branch_type
;
6689 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6692 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6697 to_fixed_variant_branch_type
6698 (TYPE_FIELD_TYPE (type
, variant_field
),
6699 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6700 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6701 if (branch_type
== NULL
)
6703 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6704 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6705 TYPE_NFIELDS (rtype
) -= 1;
6709 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6710 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6712 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6714 if (off
+ fld_bit_len
> bit_len
)
6715 bit_len
= off
+ fld_bit_len
;
6716 TYPE_LENGTH (rtype
) =
6717 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6721 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6722 should contain the alignment of that record, which should be a strictly
6723 positive value. If null or negative, then something is wrong, most
6724 probably in the debug info. In that case, we don't round up the size
6725 of the resulting type. If this record is not part of another structure,
6726 the current RTYPE length might be good enough for our purposes. */
6727 if (TYPE_LENGTH (type
) <= 0)
6729 if (TYPE_NAME (rtype
))
6730 warning (_("Invalid type size for `%s' detected: %d."),
6731 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6733 warning (_("Invalid type size for <unnamed> detected: %d."),
6734 TYPE_LENGTH (type
));
6738 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6739 TYPE_LENGTH (type
));
6742 value_free_to_mark (mark
);
6743 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6744 error (_("record type with dynamic size is larger than varsize-limit"));
6748 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6751 static struct type
*
6752 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6753 CORE_ADDR address
, struct value
*dval0
)
6755 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6759 /* An ordinary record type in which ___XVL-convention fields and
6760 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6761 static approximations, containing all possible fields. Uses
6762 no runtime values. Useless for use in values, but that's OK,
6763 since the results are used only for type determinations. Works on both
6764 structs and unions. Representation note: to save space, we memorize
6765 the result of this function in the TYPE_TARGET_TYPE of the
6768 static struct type
*
6769 template_to_static_fixed_type (struct type
*type0
)
6775 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6776 return TYPE_TARGET_TYPE (type0
);
6778 nfields
= TYPE_NFIELDS (type0
);
6781 for (f
= 0; f
< nfields
; f
+= 1)
6783 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6784 struct type
*new_type
;
6786 if (is_dynamic_field (type0
, f
))
6787 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6789 new_type
= to_static_fixed_type (field_type
);
6790 if (type
== type0
&& new_type
!= field_type
)
6792 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6793 TYPE_CODE (type
) = TYPE_CODE (type0
);
6794 INIT_CPLUS_SPECIFIC (type
);
6795 TYPE_NFIELDS (type
) = nfields
;
6796 TYPE_FIELDS (type
) = (struct field
*)
6797 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6798 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6799 sizeof (struct field
) * nfields
);
6800 TYPE_NAME (type
) = ada_type_name (type0
);
6801 TYPE_TAG_NAME (type
) = NULL
;
6802 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6803 TYPE_LENGTH (type
) = 0;
6805 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6806 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6811 /* Given an object of type TYPE whose contents are at VALADDR and
6812 whose address in memory is ADDRESS, returns a revision of TYPE --
6813 a non-dynamic-sized record with a variant part -- in which
6814 the variant part is replaced with the appropriate branch. Looks
6815 for discriminant values in DVAL0, which can be NULL if the record
6816 contains the necessary discriminant values. */
6818 static struct type
*
6819 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
6820 CORE_ADDR address
, struct value
*dval0
)
6822 struct value
*mark
= value_mark ();
6825 struct type
*branch_type
;
6826 int nfields
= TYPE_NFIELDS (type
);
6827 int variant_field
= variant_field_index (type
);
6829 if (variant_field
== -1)
6833 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6837 rtype
= alloc_type (TYPE_OBJFILE (type
));
6838 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6839 INIT_CPLUS_SPECIFIC (rtype
);
6840 TYPE_NFIELDS (rtype
) = nfields
;
6841 TYPE_FIELDS (rtype
) =
6842 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6843 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6844 sizeof (struct field
) * nfields
);
6845 TYPE_NAME (rtype
) = ada_type_name (type
);
6846 TYPE_TAG_NAME (rtype
) = NULL
;
6847 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6848 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6850 branch_type
= to_fixed_variant_branch_type
6851 (TYPE_FIELD_TYPE (type
, variant_field
),
6852 cond_offset_host (valaddr
,
6853 TYPE_FIELD_BITPOS (type
, variant_field
)
6855 cond_offset_target (address
,
6856 TYPE_FIELD_BITPOS (type
, variant_field
)
6857 / TARGET_CHAR_BIT
), dval
);
6858 if (branch_type
== NULL
)
6861 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6862 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6863 TYPE_NFIELDS (rtype
) -= 1;
6867 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6868 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6869 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6870 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6872 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6874 value_free_to_mark (mark
);
6878 /* An ordinary record type (with fixed-length fields) that describes
6879 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6880 beginning of this section]. Any necessary discriminants' values
6881 should be in DVAL, a record value; it may be NULL if the object
6882 at ADDR itself contains any necessary discriminant values.
6883 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6884 values from the record are needed. Except in the case that DVAL,
6885 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6886 unchecked) is replaced by a particular branch of the variant.
6888 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6889 is questionable and may be removed. It can arise during the
6890 processing of an unconstrained-array-of-record type where all the
6891 variant branches have exactly the same size. This is because in
6892 such cases, the compiler does not bother to use the XVS convention
6893 when encoding the record. I am currently dubious of this
6894 shortcut and suspect the compiler should be altered. FIXME. */
6896 static struct type
*
6897 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
6898 CORE_ADDR address
, struct value
*dval
)
6900 struct type
*templ_type
;
6902 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6905 templ_type
= dynamic_template_type (type0
);
6907 if (templ_type
!= NULL
)
6908 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6909 else if (variant_field_index (type0
) >= 0)
6911 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6913 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6918 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6924 /* An ordinary record type (with fixed-length fields) that describes
6925 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6926 union type. Any necessary discriminants' values should be in DVAL,
6927 a record value. That is, this routine selects the appropriate
6928 branch of the union at ADDR according to the discriminant value
6929 indicated in the union's type name. */
6931 static struct type
*
6932 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
6933 CORE_ADDR address
, struct value
*dval
)
6936 struct type
*templ_type
;
6937 struct type
*var_type
;
6939 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6940 var_type
= TYPE_TARGET_TYPE (var_type0
);
6942 var_type
= var_type0
;
6944 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6946 if (templ_type
!= NULL
)
6947 var_type
= templ_type
;
6950 ada_which_variant_applies (var_type
,
6951 value_type (dval
), value_contents (dval
));
6954 return empty_record (TYPE_OBJFILE (var_type
));
6955 else if (is_dynamic_field (var_type
, which
))
6956 return to_fixed_record_type
6957 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6958 valaddr
, address
, dval
);
6959 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6961 to_fixed_record_type
6962 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6964 return TYPE_FIELD_TYPE (var_type
, which
);
6967 /* Assuming that TYPE0 is an array type describing the type of a value
6968 at ADDR, and that DVAL describes a record containing any
6969 discriminants used in TYPE0, returns a type for the value that
6970 contains no dynamic components (that is, no components whose sizes
6971 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6972 true, gives an error message if the resulting type's size is over
6975 static struct type
*
6976 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6979 struct type
*index_type_desc
;
6980 struct type
*result
;
6982 if (ada_is_packed_array_type (type0
) /* revisit? */
6983 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6986 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6987 if (index_type_desc
== NULL
)
6989 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6990 /* NOTE: elt_type---the fixed version of elt_type0---should never
6991 depend on the contents of the array in properly constructed
6993 /* Create a fixed version of the array element type.
6994 We're not providing the address of an element here,
6995 and thus the actual object value cannot be inspected to do
6996 the conversion. This should not be a problem, since arrays of
6997 unconstrained objects are not allowed. In particular, all
6998 the elements of an array of a tagged type should all be of
6999 the same type specified in the debugging info. No need to
7000 consult the object tag. */
7001 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
7003 if (elt_type0
== elt_type
)
7006 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7007 elt_type
, TYPE_INDEX_TYPE (type0
));
7012 struct type
*elt_type0
;
7015 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7016 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7018 /* NOTE: result---the fixed version of elt_type0---should never
7019 depend on the contents of the array in properly constructed
7021 /* Create a fixed version of the array element type.
7022 We're not providing the address of an element here,
7023 and thus the actual object value cannot be inspected to do
7024 the conversion. This should not be a problem, since arrays of
7025 unconstrained objects are not allowed. In particular, all
7026 the elements of an array of a tagged type should all be of
7027 the same type specified in the debugging info. No need to
7028 consult the object tag. */
7029 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
7030 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7032 struct type
*range_type
=
7033 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
7034 dval
, TYPE_OBJFILE (type0
));
7035 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7036 result
, range_type
);
7038 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7039 error (_("array type with dynamic size is larger than varsize-limit"));
7042 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
7047 /* A standard type (containing no dynamically sized components)
7048 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7049 DVAL describes a record containing any discriminants used in TYPE0,
7050 and may be NULL if there are none, or if the object of type TYPE at
7051 ADDRESS or in VALADDR contains these discriminants.
7053 In the case of tagged types, this function attempts to locate the object's
7054 tag and use it to compute the actual type. However, when ADDRESS is null,
7055 we cannot use it to determine the location of the tag, and therefore
7056 compute the tagged type's actual type. So we return the tagged type
7057 without consulting the tag. */
7060 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7061 CORE_ADDR address
, struct value
*dval
)
7063 type
= ada_check_typedef (type
);
7064 switch (TYPE_CODE (type
))
7068 case TYPE_CODE_STRUCT
:
7070 struct type
*static_type
= to_static_fixed_type (type
);
7072 /* If STATIC_TYPE is a tagged type and we know the object's address,
7073 then we can determine its tag, and compute the object's actual
7076 if (address
!= 0 && ada_is_tagged_type (static_type
, 0))
7078 struct type
*real_type
=
7079 type_from_tag (value_tag_from_contents_and_address (static_type
,
7082 if (real_type
!= NULL
)
7085 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
7087 case TYPE_CODE_ARRAY
:
7088 return to_fixed_array_type (type
, dval
, 1);
7089 case TYPE_CODE_UNION
:
7093 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7097 /* A standard (static-sized) type corresponding as well as possible to
7098 TYPE0, but based on no runtime data. */
7100 static struct type
*
7101 to_static_fixed_type (struct type
*type0
)
7108 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
7111 type0
= ada_check_typedef (type0
);
7113 switch (TYPE_CODE (type0
))
7117 case TYPE_CODE_STRUCT
:
7118 type
= dynamic_template_type (type0
);
7120 return template_to_static_fixed_type (type
);
7122 return template_to_static_fixed_type (type0
);
7123 case TYPE_CODE_UNION
:
7124 type
= ada_find_parallel_type (type0
, "___XVU");
7126 return template_to_static_fixed_type (type
);
7128 return template_to_static_fixed_type (type0
);
7132 /* A static approximation of TYPE with all type wrappers removed. */
7134 static struct type
*
7135 static_unwrap_type (struct type
*type
)
7137 if (ada_is_aligner_type (type
))
7139 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7140 if (ada_type_name (type1
) == NULL
)
7141 TYPE_NAME (type1
) = ada_type_name (type
);
7143 return static_unwrap_type (type1
);
7147 struct type
*raw_real_type
= ada_get_base_type (type
);
7148 if (raw_real_type
== type
)
7151 return to_static_fixed_type (raw_real_type
);
7155 /* In some cases, incomplete and private types require
7156 cross-references that are not resolved as records (for example,
7158 type FooP is access Foo;
7160 type Foo is array ...;
7161 ). In these cases, since there is no mechanism for producing
7162 cross-references to such types, we instead substitute for FooP a
7163 stub enumeration type that is nowhere resolved, and whose tag is
7164 the name of the actual type. Call these types "non-record stubs". */
7166 /* A type equivalent to TYPE that is not a non-record stub, if one
7167 exists, otherwise TYPE. */
7170 ada_check_typedef (struct type
*type
)
7172 CHECK_TYPEDEF (type
);
7173 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7174 || !TYPE_STUB (type
)
7175 || TYPE_TAG_NAME (type
) == NULL
)
7179 char *name
= TYPE_TAG_NAME (type
);
7180 struct type
*type1
= ada_find_any_type (name
);
7181 return (type1
== NULL
) ? type
: type1
;
7185 /* A value representing the data at VALADDR/ADDRESS as described by
7186 type TYPE0, but with a standard (static-sized) type that correctly
7187 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7188 type, then return VAL0 [this feature is simply to avoid redundant
7189 creation of struct values]. */
7191 static struct value
*
7192 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7195 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
7196 if (type
== type0
&& val0
!= NULL
)
7199 return value_from_contents_and_address (type
, 0, address
);
7202 /* A value representing VAL, but with a standard (static-sized) type
7203 that correctly describes it. Does not necessarily create a new
7206 static struct value
*
7207 ada_to_fixed_value (struct value
*val
)
7209 return ada_to_fixed_value_create (value_type (val
),
7210 VALUE_ADDRESS (val
) + value_offset (val
),
7214 /* A value representing VAL, but with a standard (static-sized) type
7215 chosen to approximate the real type of VAL as well as possible, but
7216 without consulting any runtime values. For Ada dynamic-sized
7217 types, therefore, the type of the result is likely to be inaccurate. */
7220 ada_to_static_fixed_value (struct value
*val
)
7223 to_static_fixed_type (static_unwrap_type (value_type (val
)));
7224 if (type
== value_type (val
))
7227 return coerce_unspec_val_to_type (val
, type
);
7233 /* Table mapping attribute numbers to names.
7234 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7236 static const char *attribute_names
[] = {
7254 ada_attribute_name (enum exp_opcode n
)
7256 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7257 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7259 return attribute_names
[0];
7262 /* Evaluate the 'POS attribute applied to ARG. */
7265 pos_atr (struct value
*arg
)
7267 struct type
*type
= value_type (arg
);
7269 if (!discrete_type_p (type
))
7270 error (_("'POS only defined on discrete types"));
7272 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7275 LONGEST v
= value_as_long (arg
);
7277 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7279 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7282 error (_("enumeration value is invalid: can't find 'POS"));
7285 return value_as_long (arg
);
7288 static struct value
*
7289 value_pos_atr (struct value
*arg
)
7291 return value_from_longest (builtin_type_int
, pos_atr (arg
));
7294 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7296 static struct value
*
7297 value_val_atr (struct type
*type
, struct value
*arg
)
7299 if (!discrete_type_p (type
))
7300 error (_("'VAL only defined on discrete types"));
7301 if (!integer_type_p (value_type (arg
)))
7302 error (_("'VAL requires integral argument"));
7304 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7306 long pos
= value_as_long (arg
);
7307 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7308 error (_("argument to 'VAL out of range"));
7309 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7312 return value_from_longest (type
, value_as_long (arg
));
7318 /* True if TYPE appears to be an Ada character type.
7319 [At the moment, this is true only for Character and Wide_Character;
7320 It is a heuristic test that could stand improvement]. */
7323 ada_is_character_type (struct type
*type
)
7327 /* If the type code says it's a character, then assume it really is,
7328 and don't check any further. */
7329 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7332 /* Otherwise, assume it's a character type iff it is a discrete type
7333 with a known character type name. */
7334 name
= ada_type_name (type
);
7335 return (name
!= NULL
7336 && (TYPE_CODE (type
) == TYPE_CODE_INT
7337 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7338 && (strcmp (name
, "character") == 0
7339 || strcmp (name
, "wide_character") == 0
7340 || strcmp (name
, "wide_wide_character") == 0
7341 || strcmp (name
, "unsigned char") == 0));
7344 /* True if TYPE appears to be an Ada string type. */
7347 ada_is_string_type (struct type
*type
)
7349 type
= ada_check_typedef (type
);
7351 && TYPE_CODE (type
) != TYPE_CODE_PTR
7352 && (ada_is_simple_array_type (type
)
7353 || ada_is_array_descriptor_type (type
))
7354 && ada_array_arity (type
) == 1)
7356 struct type
*elttype
= ada_array_element_type (type
, 1);
7358 return ada_is_character_type (elttype
);
7365 /* True if TYPE is a struct type introduced by the compiler to force the
7366 alignment of a value. Such types have a single field with a
7367 distinctive name. */
7370 ada_is_aligner_type (struct type
*type
)
7372 type
= ada_check_typedef (type
);
7374 /* If we can find a parallel XVS type, then the XVS type should
7375 be used instead of this type. And hence, this is not an aligner
7377 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
7380 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7381 && TYPE_NFIELDS (type
) == 1
7382 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7385 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7386 the parallel type. */
7389 ada_get_base_type (struct type
*raw_type
)
7391 struct type
*real_type_namer
;
7392 struct type
*raw_real_type
;
7394 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7397 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7398 if (real_type_namer
== NULL
7399 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7400 || TYPE_NFIELDS (real_type_namer
) != 1)
7403 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7404 if (raw_real_type
== NULL
)
7407 return raw_real_type
;
7410 /* The type of value designated by TYPE, with all aligners removed. */
7413 ada_aligned_type (struct type
*type
)
7415 if (ada_is_aligner_type (type
))
7416 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7418 return ada_get_base_type (type
);
7422 /* The address of the aligned value in an object at address VALADDR
7423 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7426 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7428 if (ada_is_aligner_type (type
))
7429 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7431 TYPE_FIELD_BITPOS (type
,
7432 0) / TARGET_CHAR_BIT
);
7439 /* The printed representation of an enumeration literal with encoded
7440 name NAME. The value is good to the next call of ada_enum_name. */
7442 ada_enum_name (const char *name
)
7444 static char *result
;
7445 static size_t result_len
= 0;
7448 /* First, unqualify the enumeration name:
7449 1. Search for the last '.' character. If we find one, then skip
7450 all the preceeding characters, the unqualified name starts
7451 right after that dot.
7452 2. Otherwise, we may be debugging on a target where the compiler
7453 translates dots into "__". Search forward for double underscores,
7454 but stop searching when we hit an overloading suffix, which is
7455 of the form "__" followed by digits. */
7457 tmp
= strrchr (name
, '.');
7462 while ((tmp
= strstr (name
, "__")) != NULL
)
7464 if (isdigit (tmp
[2]))
7474 if (name
[1] == 'U' || name
[1] == 'W')
7476 if (sscanf (name
+ 2, "%x", &v
) != 1)
7482 GROW_VECT (result
, result_len
, 16);
7483 if (isascii (v
) && isprint (v
))
7484 sprintf (result
, "'%c'", v
);
7485 else if (name
[1] == 'U')
7486 sprintf (result
, "[\"%02x\"]", v
);
7488 sprintf (result
, "[\"%04x\"]", v
);
7494 tmp
= strstr (name
, "__");
7496 tmp
= strstr (name
, "$");
7499 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
7500 strncpy (result
, name
, tmp
- name
);
7501 result
[tmp
- name
] = '\0';
7509 static struct value
*
7510 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
7513 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7514 (expect_type
, exp
, pos
, noside
);
7517 /* Evaluate the subexpression of EXP starting at *POS as for
7518 evaluate_type, updating *POS to point just past the evaluated
7521 static struct value
*
7522 evaluate_subexp_type (struct expression
*exp
, int *pos
)
7524 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7525 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
7528 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7531 static struct value
*
7532 unwrap_value (struct value
*val
)
7534 struct type
*type
= ada_check_typedef (value_type (val
));
7535 if (ada_is_aligner_type (type
))
7537 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
7538 NULL
, "internal structure");
7539 struct type
*val_type
= ada_check_typedef (value_type (v
));
7540 if (ada_type_name (val_type
) == NULL
)
7541 TYPE_NAME (val_type
) = ada_type_name (type
);
7543 return unwrap_value (v
);
7547 struct type
*raw_real_type
=
7548 ada_check_typedef (ada_get_base_type (type
));
7550 if (type
== raw_real_type
)
7554 coerce_unspec_val_to_type
7555 (val
, ada_to_fixed_type (raw_real_type
, 0,
7556 VALUE_ADDRESS (val
) + value_offset (val
),
7561 static struct value
*
7562 cast_to_fixed (struct type
*type
, struct value
*arg
)
7566 if (type
== value_type (arg
))
7568 else if (ada_is_fixed_point_type (value_type (arg
)))
7569 val
= ada_float_to_fixed (type
,
7570 ada_fixed_to_float (value_type (arg
),
7571 value_as_long (arg
)));
7575 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
7576 val
= ada_float_to_fixed (type
, argd
);
7579 return value_from_longest (type
, val
);
7582 static struct value
*
7583 cast_from_fixed_to_double (struct value
*arg
)
7585 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7586 value_as_long (arg
));
7587 return value_from_double (builtin_type_double
, val
);
7590 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7591 return the converted value. */
7593 static struct value
*
7594 coerce_for_assign (struct type
*type
, struct value
*val
)
7596 struct type
*type2
= value_type (val
);
7600 type2
= ada_check_typedef (type2
);
7601 type
= ada_check_typedef (type
);
7603 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7604 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7606 val
= ada_value_ind (val
);
7607 type2
= value_type (val
);
7610 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7611 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7613 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7614 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7615 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7616 error (_("Incompatible types in assignment"));
7617 deprecated_set_value_type (val
, type
);
7622 static struct value
*
7623 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7626 struct type
*type1
, *type2
;
7629 arg1
= coerce_ref (arg1
);
7630 arg2
= coerce_ref (arg2
);
7631 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7632 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7634 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7635 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7636 return value_binop (arg1
, arg2
, op
);
7645 return value_binop (arg1
, arg2
, op
);
7648 v2
= value_as_long (arg2
);
7650 error (_("second operand of %s must not be zero."), op_string (op
));
7652 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7653 return value_binop (arg1
, arg2
, op
);
7655 v1
= value_as_long (arg1
);
7660 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7661 v
+= v
> 0 ? -1 : 1;
7669 /* Should not reach this point. */
7673 val
= allocate_value (type1
);
7674 store_unsigned_integer (value_contents_raw (val
),
7675 TYPE_LENGTH (value_type (val
)), v
);
7680 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7682 if (ada_is_direct_array_type (value_type (arg1
))
7683 || ada_is_direct_array_type (value_type (arg2
)))
7685 arg1
= ada_coerce_to_simple_array (arg1
);
7686 arg2
= ada_coerce_to_simple_array (arg2
);
7687 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7688 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7689 error (_("Attempt to compare array with non-array"));
7690 /* FIXME: The following works only for types whose
7691 representations use all bits (no padding or undefined bits)
7692 and do not have user-defined equality. */
7694 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7695 && memcmp (value_contents (arg1
), value_contents (arg2
),
7696 TYPE_LENGTH (value_type (arg1
))) == 0;
7698 return value_equal (arg1
, arg2
);
7701 /* Total number of component associations in the aggregate starting at
7702 index PC in EXP. Assumes that index PC is the start of an
7706 num_component_specs (struct expression
*exp
, int pc
)
7709 m
= exp
->elts
[pc
+ 1].longconst
;
7712 for (i
= 0; i
< m
; i
+= 1)
7714 switch (exp
->elts
[pc
].opcode
)
7720 n
+= exp
->elts
[pc
+ 1].longconst
;
7723 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
7728 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
7729 component of LHS (a simple array or a record), updating *POS past
7730 the expression, assuming that LHS is contained in CONTAINER. Does
7731 not modify the inferior's memory, nor does it modify LHS (unless
7732 LHS == CONTAINER). */
7735 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
7736 struct expression
*exp
, int *pos
)
7738 struct value
*mark
= value_mark ();
7740 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
7742 struct value
*index_val
= value_from_longest (builtin_type_int
, index
);
7743 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
7747 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
7748 elt
= ada_to_fixed_value (unwrap_value (elt
));
7751 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
7752 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
7754 value_assign_to_component (container
, elt
,
7755 ada_evaluate_subexp (NULL
, exp
, pos
,
7758 value_free_to_mark (mark
);
7761 /* Assuming that LHS represents an lvalue having a record or array
7762 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
7763 of that aggregate's value to LHS, advancing *POS past the
7764 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
7765 lvalue containing LHS (possibly LHS itself). Does not modify
7766 the inferior's memory, nor does it modify the contents of
7767 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
7769 static struct value
*
7770 assign_aggregate (struct value
*container
,
7771 struct value
*lhs
, struct expression
*exp
,
7772 int *pos
, enum noside noside
)
7774 struct type
*lhs_type
;
7775 int n
= exp
->elts
[*pos
+1].longconst
;
7776 LONGEST low_index
, high_index
;
7779 int max_indices
, num_indices
;
7780 int is_array_aggregate
;
7782 struct value
*mark
= value_mark ();
7785 if (noside
!= EVAL_NORMAL
)
7788 for (i
= 0; i
< n
; i
+= 1)
7789 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
7793 container
= ada_coerce_ref (container
);
7794 if (ada_is_direct_array_type (value_type (container
)))
7795 container
= ada_coerce_to_simple_array (container
);
7796 lhs
= ada_coerce_ref (lhs
);
7797 if (!deprecated_value_modifiable (lhs
))
7798 error (_("Left operand of assignment is not a modifiable lvalue."));
7800 lhs_type
= value_type (lhs
);
7801 if (ada_is_direct_array_type (lhs_type
))
7803 lhs
= ada_coerce_to_simple_array (lhs
);
7804 lhs_type
= value_type (lhs
);
7805 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
7806 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
7807 is_array_aggregate
= 1;
7809 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
7812 high_index
= num_visible_fields (lhs_type
) - 1;
7813 is_array_aggregate
= 0;
7816 error (_("Left-hand side must be array or record."));
7818 num_specs
= num_component_specs (exp
, *pos
- 3);
7819 max_indices
= 4 * num_specs
+ 4;
7820 indices
= alloca (max_indices
* sizeof (indices
[0]));
7821 indices
[0] = indices
[1] = low_index
- 1;
7822 indices
[2] = indices
[3] = high_index
+ 1;
7825 for (i
= 0; i
< n
; i
+= 1)
7827 switch (exp
->elts
[*pos
].opcode
)
7830 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
7831 &num_indices
, max_indices
,
7832 low_index
, high_index
);
7835 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
7836 &num_indices
, max_indices
,
7837 low_index
, high_index
);
7841 error (_("Misplaced 'others' clause"));
7842 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
7843 num_indices
, low_index
, high_index
);
7846 error (_("Internal error: bad aggregate clause"));
7853 /* Assign into the component of LHS indexed by the OP_POSITIONAL
7854 construct at *POS, updating *POS past the construct, given that
7855 the positions are relative to lower bound LOW, where HIGH is the
7856 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
7857 updating *NUM_INDICES as needed. CONTAINER is as for
7858 assign_aggregate. */
7860 aggregate_assign_positional (struct value
*container
,
7861 struct value
*lhs
, struct expression
*exp
,
7862 int *pos
, LONGEST
*indices
, int *num_indices
,
7863 int max_indices
, LONGEST low
, LONGEST high
)
7865 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
7867 if (ind
- 1 == high
)
7868 warning (_("Extra components in aggregate ignored."));
7871 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
7873 assign_component (container
, lhs
, ind
, exp
, pos
);
7876 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
7879 /* Assign into the components of LHS indexed by the OP_CHOICES
7880 construct at *POS, updating *POS past the construct, given that
7881 the allowable indices are LOW..HIGH. Record the indices assigned
7882 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
7883 needed. CONTAINER is as for assign_aggregate. */
7885 aggregate_assign_from_choices (struct value
*container
,
7886 struct value
*lhs
, struct expression
*exp
,
7887 int *pos
, LONGEST
*indices
, int *num_indices
,
7888 int max_indices
, LONGEST low
, LONGEST high
)
7891 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
7892 int choice_pos
, expr_pc
;
7893 int is_array
= ada_is_direct_array_type (value_type (lhs
));
7895 choice_pos
= *pos
+= 3;
7897 for (j
= 0; j
< n_choices
; j
+= 1)
7898 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
7900 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
7902 for (j
= 0; j
< n_choices
; j
+= 1)
7904 LONGEST lower
, upper
;
7905 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
7906 if (op
== OP_DISCRETE_RANGE
)
7909 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
7911 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
7916 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
7927 name
= &exp
->elts
[choice_pos
+ 2].string
;
7930 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
7933 error (_("Invalid record component association."));
7935 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
7937 if (! find_struct_field (name
, value_type (lhs
), 0,
7938 NULL
, NULL
, NULL
, NULL
, &ind
))
7939 error (_("Unknown component name: %s."), name
);
7940 lower
= upper
= ind
;
7943 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
7944 error (_("Index in component association out of bounds."));
7946 add_component_interval (lower
, upper
, indices
, num_indices
,
7948 while (lower
<= upper
)
7952 assign_component (container
, lhs
, lower
, exp
, &pos1
);
7958 /* Assign the value of the expression in the OP_OTHERS construct in
7959 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
7960 have not been previously assigned. The index intervals already assigned
7961 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
7962 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
7964 aggregate_assign_others (struct value
*container
,
7965 struct value
*lhs
, struct expression
*exp
,
7966 int *pos
, LONGEST
*indices
, int num_indices
,
7967 LONGEST low
, LONGEST high
)
7970 int expr_pc
= *pos
+1;
7972 for (i
= 0; i
< num_indices
- 2; i
+= 2)
7975 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
7979 assign_component (container
, lhs
, ind
, exp
, &pos
);
7982 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
7985 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
7986 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
7987 modifying *SIZE as needed. It is an error if *SIZE exceeds
7988 MAX_SIZE. The resulting intervals do not overlap. */
7990 add_component_interval (LONGEST low
, LONGEST high
,
7991 LONGEST
* indices
, int *size
, int max_size
)
7994 for (i
= 0; i
< *size
; i
+= 2) {
7995 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
7998 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
7999 if (high
< indices
[kh
])
8001 if (low
< indices
[i
])
8003 indices
[i
+ 1] = indices
[kh
- 1];
8004 if (high
> indices
[i
+ 1])
8005 indices
[i
+ 1] = high
;
8006 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8007 *size
-= kh
- i
- 2;
8010 else if (high
< indices
[i
])
8014 if (*size
== max_size
)
8015 error (_("Internal error: miscounted aggregate components."));
8017 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8018 indices
[j
] = indices
[j
- 2];
8020 indices
[i
+ 1] = high
;
8023 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8026 static struct value
*
8027 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8029 if (type
== ada_check_typedef (value_type (arg2
)))
8032 if (ada_is_fixed_point_type (type
))
8033 return (cast_to_fixed (type
, arg2
));
8035 if (ada_is_fixed_point_type (value_type (arg2
)))
8036 return value_cast (type
, cast_from_fixed_to_double (arg2
));
8038 return value_cast (type
, arg2
);
8041 static struct value
*
8042 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8043 int *pos
, enum noside noside
)
8046 int tem
, tem2
, tem3
;
8048 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8051 struct value
**argvec
;
8055 op
= exp
->elts
[pc
].opcode
;
8061 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8062 arg1
= unwrap_value (arg1
);
8064 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8065 then we need to perform the conversion manually, because
8066 evaluate_subexp_standard doesn't do it. This conversion is
8067 necessary in Ada because the different kinds of float/fixed
8068 types in Ada have different representations.
8070 Similarly, we need to perform the conversion from OP_LONG
8072 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8073 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8079 struct value
*result
;
8081 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8082 /* The result type will have code OP_STRING, bashed there from
8083 OP_ARRAY. Bash it back. */
8084 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8085 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8091 type
= exp
->elts
[pc
+ 1].type
;
8092 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8093 if (noside
== EVAL_SKIP
)
8095 arg1
= ada_value_cast (type
, arg1
, noside
);
8100 type
= exp
->elts
[pc
+ 1].type
;
8101 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8104 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8105 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8107 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8108 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8110 return ada_value_assign (arg1
, arg1
);
8112 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8113 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8115 if (ada_is_fixed_point_type (value_type (arg1
)))
8116 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8117 else if (ada_is_fixed_point_type (value_type (arg2
)))
8119 (_("Fixed-point values must be assigned to fixed-point variables"));
8121 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8122 return ada_value_assign (arg1
, arg2
);
8125 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8126 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8127 if (noside
== EVAL_SKIP
)
8129 if ((ada_is_fixed_point_type (value_type (arg1
))
8130 || ada_is_fixed_point_type (value_type (arg2
)))
8131 && value_type (arg1
) != value_type (arg2
))
8132 error (_("Operands of fixed-point addition must have the same type"));
8133 /* Do the addition, and cast the result to the type of the first
8134 argument. We cannot cast the result to a reference type, so if
8135 ARG1 is a reference type, find its underlying type. */
8136 type
= value_type (arg1
);
8137 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8138 type
= TYPE_TARGET_TYPE (type
);
8139 return value_cast (type
, value_add (arg1
, arg2
));
8142 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8143 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8144 if (noside
== EVAL_SKIP
)
8146 if ((ada_is_fixed_point_type (value_type (arg1
))
8147 || ada_is_fixed_point_type (value_type (arg2
)))
8148 && value_type (arg1
) != value_type (arg2
))
8149 error (_("Operands of fixed-point subtraction must have the same type"));
8150 /* Do the substraction, and cast the result to the type of the first
8151 argument. We cannot cast the result to a reference type, so if
8152 ARG1 is a reference type, find its underlying type. */
8153 type
= value_type (arg1
);
8154 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8155 type
= TYPE_TARGET_TYPE (type
);
8156 return value_cast (type
, value_sub (arg1
, arg2
));
8160 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8161 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8162 if (noside
== EVAL_SKIP
)
8164 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8165 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8166 return value_zero (value_type (arg1
), not_lval
);
8169 if (ada_is_fixed_point_type (value_type (arg1
)))
8170 arg1
= cast_from_fixed_to_double (arg1
);
8171 if (ada_is_fixed_point_type (value_type (arg2
)))
8172 arg2
= cast_from_fixed_to_double (arg2
);
8173 return ada_value_binop (arg1
, arg2
, op
);
8178 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8179 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8180 if (noside
== EVAL_SKIP
)
8182 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8183 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8184 return value_zero (value_type (arg1
), not_lval
);
8186 return ada_value_binop (arg1
, arg2
, op
);
8189 case BINOP_NOTEQUAL
:
8190 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8191 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8192 if (noside
== EVAL_SKIP
)
8194 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8197 tem
= ada_value_equal (arg1
, arg2
);
8198 if (op
== BINOP_NOTEQUAL
)
8200 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
8203 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8204 if (noside
== EVAL_SKIP
)
8206 else if (ada_is_fixed_point_type (value_type (arg1
)))
8207 return value_cast (value_type (arg1
), value_neg (arg1
));
8209 return value_neg (arg1
);
8211 case BINOP_LOGICAL_AND
:
8212 case BINOP_LOGICAL_OR
:
8213 case UNOP_LOGICAL_NOT
:
8218 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8219 return value_cast (LA_BOOL_TYPE
, val
);
8222 case BINOP_BITWISE_AND
:
8223 case BINOP_BITWISE_IOR
:
8224 case BINOP_BITWISE_XOR
:
8228 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8230 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8232 return value_cast (value_type (arg1
), val
);
8237 if (noside
== EVAL_SKIP
)
8242 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8243 /* Only encountered when an unresolved symbol occurs in a
8244 context other than a function call, in which case, it is
8246 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8247 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8248 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8252 (to_static_fixed_type
8253 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8259 unwrap_value (evaluate_subexp_standard
8260 (expect_type
, exp
, pos
, noside
));
8261 return ada_to_fixed_value (arg1
);
8267 /* Allocate arg vector, including space for the function to be
8268 called in argvec[0] and a terminating NULL. */
8269 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8271 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8273 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8274 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8275 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8276 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8279 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8280 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8283 if (noside
== EVAL_SKIP
)
8287 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
8288 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8289 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
8290 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
8291 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8292 argvec
[0] = value_addr (argvec
[0]);
8294 type
= ada_check_typedef (value_type (argvec
[0]));
8295 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8297 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
8299 case TYPE_CODE_FUNC
:
8300 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8302 case TYPE_CODE_ARRAY
:
8304 case TYPE_CODE_STRUCT
:
8305 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8306 argvec
[0] = ada_value_ind (argvec
[0]);
8307 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8310 error (_("cannot subscript or call something of type `%s'"),
8311 ada_type_name (value_type (argvec
[0])));
8316 switch (TYPE_CODE (type
))
8318 case TYPE_CODE_FUNC
:
8319 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8320 return allocate_value (TYPE_TARGET_TYPE (type
));
8321 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8322 case TYPE_CODE_STRUCT
:
8326 arity
= ada_array_arity (type
);
8327 type
= ada_array_element_type (type
, nargs
);
8329 error (_("cannot subscript or call a record"));
8331 error (_("wrong number of subscripts; expecting %d"), arity
);
8332 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8333 return allocate_value (ada_aligned_type (type
));
8335 unwrap_value (ada_value_subscript
8336 (argvec
[0], nargs
, argvec
+ 1));
8338 case TYPE_CODE_ARRAY
:
8339 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8341 type
= ada_array_element_type (type
, nargs
);
8343 error (_("element type of array unknown"));
8345 return allocate_value (ada_aligned_type (type
));
8348 unwrap_value (ada_value_subscript
8349 (ada_coerce_to_simple_array (argvec
[0]),
8350 nargs
, argvec
+ 1));
8351 case TYPE_CODE_PTR
: /* Pointer to array */
8352 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8353 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8355 type
= ada_array_element_type (type
, nargs
);
8357 error (_("element type of array unknown"));
8359 return allocate_value (ada_aligned_type (type
));
8362 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8363 nargs
, argvec
+ 1));
8366 error (_("Attempt to index or call something other than an "
8367 "array or function"));
8372 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8373 struct value
*low_bound_val
=
8374 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8375 struct value
*high_bound_val
=
8376 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8379 low_bound_val
= coerce_ref (low_bound_val
);
8380 high_bound_val
= coerce_ref (high_bound_val
);
8381 low_bound
= pos_atr (low_bound_val
);
8382 high_bound
= pos_atr (high_bound_val
);
8384 if (noside
== EVAL_SKIP
)
8387 /* If this is a reference to an aligner type, then remove all
8389 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8390 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
8391 TYPE_TARGET_TYPE (value_type (array
)) =
8392 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
8394 if (ada_is_packed_array_type (value_type (array
)))
8395 error (_("cannot slice a packed array"));
8397 /* If this is a reference to an array or an array lvalue,
8398 convert to a pointer. */
8399 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8400 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
8401 && VALUE_LVAL (array
) == lval_memory
))
8402 array
= value_addr (array
);
8404 if (noside
== EVAL_AVOID_SIDE_EFFECTS
8405 && ada_is_array_descriptor_type (ada_check_typedef
8406 (value_type (array
))))
8407 return empty_array (ada_type_of_array (array
, 0), low_bound
);
8409 array
= ada_coerce_to_simple_array_ptr (array
);
8411 /* If we have more than one level of pointer indirection,
8412 dereference the value until we get only one level. */
8413 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
8414 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
8416 array
= value_ind (array
);
8418 /* Make sure we really do have an array type before going further,
8419 to avoid a SEGV when trying to get the index type or the target
8420 type later down the road if the debug info generated by
8421 the compiler is incorrect or incomplete. */
8422 if (!ada_is_simple_array_type (value_type (array
)))
8423 error (_("cannot take slice of non-array"));
8425 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
8427 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8428 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
8432 struct type
*arr_type0
=
8433 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
8435 return ada_value_slice_ptr (array
, arr_type0
,
8436 longest_to_int (low_bound
),
8437 longest_to_int (high_bound
));
8440 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8442 else if (high_bound
< low_bound
)
8443 return empty_array (value_type (array
), low_bound
);
8445 return ada_value_slice (array
, longest_to_int (low_bound
),
8446 longest_to_int (high_bound
));
8451 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8452 type
= exp
->elts
[pc
+ 1].type
;
8454 if (noside
== EVAL_SKIP
)
8457 switch (TYPE_CODE (type
))
8460 lim_warning (_("Membership test incompletely implemented; "
8461 "always returns true"));
8462 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
8464 case TYPE_CODE_RANGE
:
8465 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
8466 arg3
= value_from_longest (builtin_type_int
,
8467 TYPE_HIGH_BOUND (type
));
8469 value_from_longest (builtin_type_int
,
8470 (value_less (arg1
, arg3
)
8471 || value_equal (arg1
, arg3
))
8472 && (value_less (arg2
, arg1
)
8473 || value_equal (arg2
, arg1
)));
8476 case BINOP_IN_BOUNDS
:
8478 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8479 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8481 if (noside
== EVAL_SKIP
)
8484 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8485 return value_zero (builtin_type_int
, not_lval
);
8487 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8489 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
8490 error (_("invalid dimension number to 'range"));
8492 arg3
= ada_array_bound (arg2
, tem
, 1);
8493 arg2
= ada_array_bound (arg2
, tem
, 0);
8496 value_from_longest (builtin_type_int
,
8497 (value_less (arg1
, arg3
)
8498 || value_equal (arg1
, arg3
))
8499 && (value_less (arg2
, arg1
)
8500 || value_equal (arg2
, arg1
)));
8502 case TERNOP_IN_RANGE
:
8503 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8504 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8505 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8507 if (noside
== EVAL_SKIP
)
8511 value_from_longest (builtin_type_int
,
8512 (value_less (arg1
, arg3
)
8513 || value_equal (arg1
, arg3
))
8514 && (value_less (arg2
, arg1
)
8515 || value_equal (arg2
, arg1
)));
8521 struct type
*type_arg
;
8522 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8524 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8526 type_arg
= exp
->elts
[pc
+ 2].type
;
8530 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8534 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
8535 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
8536 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
8539 if (noside
== EVAL_SKIP
)
8542 if (type_arg
== NULL
)
8544 arg1
= ada_coerce_ref (arg1
);
8546 if (ada_is_packed_array_type (value_type (arg1
)))
8547 arg1
= ada_coerce_to_simple_array (arg1
);
8549 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
8550 error (_("invalid dimension number to '%s"),
8551 ada_attribute_name (op
));
8553 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8555 type
= ada_index_type (value_type (arg1
), tem
);
8558 (_("attempt to take bound of something that is not an array"));
8559 return allocate_value (type
);
8564 default: /* Should never happen. */
8565 error (_("unexpected attribute encountered"));
8567 return ada_array_bound (arg1
, tem
, 0);
8569 return ada_array_bound (arg1
, tem
, 1);
8571 return ada_array_length (arg1
, tem
);
8574 else if (discrete_type_p (type_arg
))
8576 struct type
*range_type
;
8577 char *name
= ada_type_name (type_arg
);
8579 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
8581 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
8582 if (range_type
== NULL
)
8583 range_type
= type_arg
;
8587 error (_("unexpected attribute encountered"));
8589 return discrete_type_low_bound (range_type
);
8591 return discrete_type_high_bound (range_type
);
8593 error (_("the 'length attribute applies only to array types"));
8596 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
8597 error (_("unimplemented type attribute"));
8602 if (ada_is_packed_array_type (type_arg
))
8603 type_arg
= decode_packed_array_type (type_arg
);
8605 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
8606 error (_("invalid dimension number to '%s"),
8607 ada_attribute_name (op
));
8609 type
= ada_index_type (type_arg
, tem
);
8612 (_("attempt to take bound of something that is not an array"));
8613 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8614 return allocate_value (type
);
8619 error (_("unexpected attribute encountered"));
8621 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
8622 return value_from_longest (type
, low
);
8624 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
8625 return value_from_longest (type
, high
);
8627 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
8628 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
8629 return value_from_longest (type
, high
- low
+ 1);
8635 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8636 if (noside
== EVAL_SKIP
)
8639 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8640 return value_zero (ada_tag_type (arg1
), not_lval
);
8642 return ada_value_tag (arg1
);
8646 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8647 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8648 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8649 if (noside
== EVAL_SKIP
)
8651 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8652 return value_zero (value_type (arg1
), not_lval
);
8654 return value_binop (arg1
, arg2
,
8655 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
8657 case OP_ATR_MODULUS
:
8659 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
8660 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8662 if (noside
== EVAL_SKIP
)
8665 if (!ada_is_modular_type (type_arg
))
8666 error (_("'modulus must be applied to modular type"));
8668 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
8669 ada_modulus (type_arg
));
8674 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8675 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8676 if (noside
== EVAL_SKIP
)
8678 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8679 return value_zero (builtin_type_int
, not_lval
);
8681 return value_pos_atr (arg1
);
8684 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8685 if (noside
== EVAL_SKIP
)
8687 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8688 return value_zero (builtin_type_int
, not_lval
);
8690 return value_from_longest (builtin_type_int
,
8692 * TYPE_LENGTH (value_type (arg1
)));
8695 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8696 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8697 type
= exp
->elts
[pc
+ 2].type
;
8698 if (noside
== EVAL_SKIP
)
8700 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8701 return value_zero (type
, not_lval
);
8703 return value_val_atr (type
, arg1
);
8706 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8707 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8708 if (noside
== EVAL_SKIP
)
8710 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8711 return value_zero (value_type (arg1
), not_lval
);
8713 return value_binop (arg1
, arg2
, op
);
8716 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8717 if (noside
== EVAL_SKIP
)
8723 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8724 if (noside
== EVAL_SKIP
)
8726 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
8727 return value_neg (arg1
);
8732 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
8733 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
8734 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
8735 if (noside
== EVAL_SKIP
)
8737 type
= ada_check_typedef (value_type (arg1
));
8738 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8740 if (ada_is_array_descriptor_type (type
))
8741 /* GDB allows dereferencing GNAT array descriptors. */
8743 struct type
*arrType
= ada_type_of_array (arg1
, 0);
8744 if (arrType
== NULL
)
8745 error (_("Attempt to dereference null array pointer."));
8746 return value_at_lazy (arrType
, 0);
8748 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
8749 || TYPE_CODE (type
) == TYPE_CODE_REF
8750 /* In C you can dereference an array to get the 1st elt. */
8751 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8753 type
= to_static_fixed_type
8755 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
8757 return value_zero (type
, lval_memory
);
8759 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
8760 /* GDB allows dereferencing an int. */
8761 return value_zero (builtin_type_int
, lval_memory
);
8763 error (_("Attempt to take contents of a non-pointer value."));
8765 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
8766 type
= ada_check_typedef (value_type (arg1
));
8768 if (ada_is_array_descriptor_type (type
))
8769 /* GDB allows dereferencing GNAT array descriptors. */
8770 return ada_coerce_to_simple_array (arg1
);
8772 return ada_value_ind (arg1
);
8774 case STRUCTOP_STRUCT
:
8775 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8776 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
8777 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8778 if (noside
== EVAL_SKIP
)
8780 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8782 struct type
*type1
= value_type (arg1
);
8783 if (ada_is_tagged_type (type1
, 1))
8785 type
= ada_lookup_struct_elt_type (type1
,
8786 &exp
->elts
[pc
+ 2].string
,
8789 /* In this case, we assume that the field COULD exist
8790 in some extension of the type. Return an object of
8791 "type" void, which will match any formal
8792 (see ada_type_match). */
8793 return value_zero (builtin_type_void
, lval_memory
);
8797 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
8800 return value_zero (ada_aligned_type (type
), lval_memory
);
8804 ada_to_fixed_value (unwrap_value
8805 (ada_value_struct_elt
8806 (arg1
, &exp
->elts
[pc
+ 2].string
, 0)));
8808 /* The value is not supposed to be used. This is here to make it
8809 easier to accommodate expressions that contain types. */
8811 if (noside
== EVAL_SKIP
)
8813 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8814 return allocate_value (exp
->elts
[pc
+ 1].type
);
8816 error (_("Attempt to use a type name as an expression"));
8821 case OP_DISCRETE_RANGE
:
8824 if (noside
== EVAL_NORMAL
)
8828 error (_("Undefined name, ambiguous name, or renaming used in "
8829 "component association: %s."), &exp
->elts
[pc
+2].string
);
8831 error (_("Aggregates only allowed on the right of an assignment"));
8833 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
8836 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8838 for (tem
= 0; tem
< nargs
; tem
+= 1)
8839 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8844 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
8850 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
8851 type name that encodes the 'small and 'delta information.
8852 Otherwise, return NULL. */
8855 fixed_type_info (struct type
*type
)
8857 const char *name
= ada_type_name (type
);
8858 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
8860 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
8862 const char *tail
= strstr (name
, "___XF_");
8868 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
8869 return fixed_type_info (TYPE_TARGET_TYPE (type
));
8874 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
8877 ada_is_fixed_point_type (struct type
*type
)
8879 return fixed_type_info (type
) != NULL
;
8882 /* Return non-zero iff TYPE represents a System.Address type. */
8885 ada_is_system_address_type (struct type
*type
)
8887 return (TYPE_NAME (type
)
8888 && strcmp (TYPE_NAME (type
), "system__address") == 0);
8891 /* Assuming that TYPE is the representation of an Ada fixed-point
8892 type, return its delta, or -1 if the type is malformed and the
8893 delta cannot be determined. */
8896 ada_delta (struct type
*type
)
8898 const char *encoding
= fixed_type_info (type
);
8901 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
8904 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
8907 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
8908 factor ('SMALL value) associated with the type. */
8911 scaling_factor (struct type
*type
)
8913 const char *encoding
= fixed_type_info (type
);
8914 unsigned long num0
, den0
, num1
, den1
;
8917 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
8922 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
8924 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
8928 /* Assuming that X is the representation of a value of fixed-point
8929 type TYPE, return its floating-point equivalent. */
8932 ada_fixed_to_float (struct type
*type
, LONGEST x
)
8934 return (DOUBLEST
) x
*scaling_factor (type
);
8937 /* The representation of a fixed-point value of type TYPE
8938 corresponding to the value X. */
8941 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
8943 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
8947 /* VAX floating formats */
8949 /* Non-zero iff TYPE represents one of the special VAX floating-point
8953 ada_is_vax_floating_type (struct type
*type
)
8956 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
8959 && (TYPE_CODE (type
) == TYPE_CODE_INT
8960 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8961 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
8964 /* The type of special VAX floating-point type this is, assuming
8965 ada_is_vax_floating_point. */
8968 ada_vax_float_type_suffix (struct type
*type
)
8970 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
8973 /* A value representing the special debugging function that outputs
8974 VAX floating-point values of the type represented by TYPE. Assumes
8975 ada_is_vax_floating_type (TYPE). */
8978 ada_vax_float_print_function (struct type
*type
)
8980 switch (ada_vax_float_type_suffix (type
))
8983 return get_var_value ("DEBUG_STRING_F", 0);
8985 return get_var_value ("DEBUG_STRING_D", 0);
8987 return get_var_value ("DEBUG_STRING_G", 0);
8989 error (_("invalid VAX floating-point type"));
8996 /* Scan STR beginning at position K for a discriminant name, and
8997 return the value of that discriminant field of DVAL in *PX. If
8998 PNEW_K is not null, put the position of the character beyond the
8999 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9000 not alter *PX and *PNEW_K if unsuccessful. */
9003 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9006 static char *bound_buffer
= NULL
;
9007 static size_t bound_buffer_len
= 0;
9010 struct value
*bound_val
;
9012 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9015 pend
= strstr (str
+ k
, "__");
9019 k
+= strlen (bound
);
9023 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9024 bound
= bound_buffer
;
9025 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9026 bound
[pend
- (str
+ k
)] = '\0';
9030 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9031 if (bound_val
== NULL
)
9034 *px
= value_as_long (bound_val
);
9040 /* Value of variable named NAME in the current environment. If
9041 no such variable found, then if ERR_MSG is null, returns 0, and
9042 otherwise causes an error with message ERR_MSG. */
9044 static struct value
*
9045 get_var_value (char *name
, char *err_msg
)
9047 struct ada_symbol_info
*syms
;
9050 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9055 if (err_msg
== NULL
)
9058 error (("%s"), err_msg
);
9061 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9064 /* Value of integer variable named NAME in the current environment. If
9065 no such variable found, returns 0, and sets *FLAG to 0. If
9066 successful, sets *FLAG to 1. */
9069 get_int_var_value (char *name
, int *flag
)
9071 struct value
*var_val
= get_var_value (name
, 0);
9083 return value_as_long (var_val
);
9088 /* Return a range type whose base type is that of the range type named
9089 NAME in the current environment, and whose bounds are calculated
9090 from NAME according to the GNAT range encoding conventions.
9091 Extract discriminant values, if needed, from DVAL. If a new type
9092 must be created, allocate in OBJFILE's space. The bounds
9093 information, in general, is encoded in NAME, the base type given in
9094 the named range type. */
9096 static struct type
*
9097 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9099 struct type
*raw_type
= ada_find_any_type (name
);
9100 struct type
*base_type
;
9103 if (raw_type
== NULL
)
9104 base_type
= builtin_type_int
;
9105 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9106 base_type
= TYPE_TARGET_TYPE (raw_type
);
9108 base_type
= raw_type
;
9110 subtype_info
= strstr (name
, "___XD");
9111 if (subtype_info
== NULL
)
9115 static char *name_buf
= NULL
;
9116 static size_t name_len
= 0;
9117 int prefix_len
= subtype_info
- name
;
9123 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9124 strncpy (name_buf
, name
, prefix_len
);
9125 name_buf
[prefix_len
] = '\0';
9128 bounds_str
= strchr (subtype_info
, '_');
9131 if (*subtype_info
== 'L')
9133 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9134 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9136 if (bounds_str
[n
] == '_')
9138 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9145 strcpy (name_buf
+ prefix_len
, "___L");
9146 L
= get_int_var_value (name_buf
, &ok
);
9149 lim_warning (_("Unknown lower bound, using 1."));
9154 if (*subtype_info
== 'U')
9156 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9157 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9163 strcpy (name_buf
+ prefix_len
, "___U");
9164 U
= get_int_var_value (name_buf
, &ok
);
9167 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
9172 if (objfile
== NULL
)
9173 objfile
= TYPE_OBJFILE (base_type
);
9174 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9175 TYPE_NAME (type
) = name
;
9180 /* True iff NAME is the name of a range type. */
9183 ada_is_range_type_name (const char *name
)
9185 return (name
!= NULL
&& strstr (name
, "___XD"));
9191 /* True iff TYPE is an Ada modular type. */
9194 ada_is_modular_type (struct type
*type
)
9196 struct type
*subranged_type
= base_type (type
);
9198 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9199 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
9200 && TYPE_UNSIGNED (subranged_type
));
9203 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9206 ada_modulus (struct type
* type
)
9208 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
9212 /* Ada exception catchpoint support:
9213 ---------------------------------
9215 We support 3 kinds of exception catchpoints:
9216 . catchpoints on Ada exceptions
9217 . catchpoints on unhandled Ada exceptions
9218 . catchpoints on failed assertions
9220 Exceptions raised during failed assertions, or unhandled exceptions
9221 could perfectly be caught with the general catchpoint on Ada exceptions.
9222 However, we can easily differentiate these two special cases, and having
9223 the option to distinguish these two cases from the rest can be useful
9224 to zero-in on certain situations.
9226 Exception catchpoints are a specialized form of breakpoint,
9227 since they rely on inserting breakpoints inside known routines
9228 of the GNAT runtime. The implementation therefore uses a standard
9229 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9232 Support in the runtime for exception catchpoints have been changed
9233 a few times already, and these changes affect the implementation
9234 of these catchpoints. In order to be able to support several
9235 variants of the runtime, we use a sniffer that will determine
9236 the runtime variant used by the program being debugged.
9238 At this time, we do not support the use of conditions on Ada exception
9239 catchpoints. The COND and COND_STRING fields are therefore set
9240 to NULL (most of the time, see below).
9242 Conditions where EXP_STRING, COND, and COND_STRING are used:
9244 When a user specifies the name of a specific exception in the case
9245 of catchpoints on Ada exceptions, we store the name of that exception
9246 in the EXP_STRING. We then translate this request into an actual
9247 condition stored in COND_STRING, and then parse it into an expression
9250 /* The different types of catchpoints that we introduced for catching
9253 enum exception_catchpoint_kind
9256 ex_catch_exception_unhandled
,
9260 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
9262 /* A structure that describes how to support exception catchpoints
9263 for a given executable. */
9265 struct exception_support_info
9267 /* The name of the symbol to break on in order to insert
9268 a catchpoint on exceptions. */
9269 const char *catch_exception_sym
;
9271 /* The name of the symbol to break on in order to insert
9272 a catchpoint on unhandled exceptions. */
9273 const char *catch_exception_unhandled_sym
;
9275 /* The name of the symbol to break on in order to insert
9276 a catchpoint on failed assertions. */
9277 const char *catch_assert_sym
;
9279 /* Assuming that the inferior just triggered an unhandled exception
9280 catchpoint, this function is responsible for returning the address
9281 in inferior memory where the name of that exception is stored.
9282 Return zero if the address could not be computed. */
9283 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
9286 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
9287 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
9289 /* The following exception support info structure describes how to
9290 implement exception catchpoints with the latest version of the
9291 Ada runtime (as of 2007-03-06). */
9293 static const struct exception_support_info default_exception_support_info
=
9295 "__gnat_debug_raise_exception", /* catch_exception_sym */
9296 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9297 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9298 ada_unhandled_exception_name_addr
9301 /* The following exception support info structure describes how to
9302 implement exception catchpoints with a slightly older version
9303 of the Ada runtime. */
9305 static const struct exception_support_info exception_support_info_fallback
=
9307 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9308 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9309 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9310 ada_unhandled_exception_name_addr_from_raise
9313 /* For each executable, we sniff which exception info structure to use
9314 and cache it in the following global variable. */
9316 static const struct exception_support_info
*exception_info
= NULL
;
9318 /* Inspect the Ada runtime and determine which exception info structure
9319 should be used to provide support for exception catchpoints.
9321 This function will always set exception_info, or raise an error. */
9324 ada_exception_support_info_sniffer (void)
9328 /* If the exception info is already known, then no need to recompute it. */
9329 if (exception_info
!= NULL
)
9332 /* Check the latest (default) exception support info. */
9333 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
9337 exception_info
= &default_exception_support_info
;
9341 /* Try our fallback exception suport info. */
9342 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
9346 exception_info
= &exception_support_info_fallback
;
9350 /* Sometimes, it is normal for us to not be able to find the routine
9351 we are looking for. This happens when the program is linked with
9352 the shared version of the GNAT runtime, and the program has not been
9353 started yet. Inform the user of these two possible causes if
9356 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
9357 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9359 /* If the symbol does not exist, then check that the program is
9360 already started, to make sure that shared libraries have been
9361 loaded. If it is not started, this may mean that the symbol is
9362 in a shared library. */
9364 if (ptid_get_pid (inferior_ptid
) == 0)
9365 error (_("Unable to insert catchpoint. Try to start the program first."));
9367 /* At this point, we know that we are debugging an Ada program and
9368 that the inferior has been started, but we still are not able to
9369 find the run-time symbols. That can mean that we are in
9370 configurable run time mode, or that a-except as been optimized
9371 out by the linker... In any case, at this point it is not worth
9372 supporting this feature. */
9374 error (_("Cannot insert catchpoints in this configuration."));
9377 /* An observer of "executable_changed" events.
9378 Its role is to clear certain cached values that need to be recomputed
9379 each time a new executable is loaded by GDB. */
9382 ada_executable_changed_observer (void *unused
)
9384 /* If the executable changed, then it is possible that the Ada runtime
9385 is different. So we need to invalidate the exception support info
9387 exception_info
= NULL
;
9390 /* Return the name of the function at PC, NULL if could not find it.
9391 This function only checks the debugging information, not the symbol
9395 function_name_from_pc (CORE_ADDR pc
)
9399 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
9405 /* True iff FRAME is very likely to be that of a function that is
9406 part of the runtime system. This is all very heuristic, but is
9407 intended to be used as advice as to what frames are uninteresting
9411 is_known_support_routine (struct frame_info
*frame
)
9413 struct symtab_and_line sal
;
9417 /* If this code does not have any debugging information (no symtab),
9418 This cannot be any user code. */
9420 find_frame_sal (frame
, &sal
);
9421 if (sal
.symtab
== NULL
)
9424 /* If there is a symtab, but the associated source file cannot be
9425 located, then assume this is not user code: Selecting a frame
9426 for which we cannot display the code would not be very helpful
9427 for the user. This should also take care of case such as VxWorks
9428 where the kernel has some debugging info provided for a few units. */
9430 if (symtab_to_fullname (sal
.symtab
) == NULL
)
9433 /* Check the unit filename againt the Ada runtime file naming.
9434 We also check the name of the objfile against the name of some
9435 known system libraries that sometimes come with debugging info
9438 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
9440 re_comp (known_runtime_file_name_patterns
[i
]);
9441 if (re_exec (sal
.symtab
->filename
))
9443 if (sal
.symtab
->objfile
!= NULL
9444 && re_exec (sal
.symtab
->objfile
->name
))
9448 /* Check whether the function is a GNAT-generated entity. */
9450 func_name
= function_name_from_pc (get_frame_address_in_block (frame
));
9451 if (func_name
== NULL
)
9454 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
9456 re_comp (known_auxiliary_function_name_patterns
[i
]);
9457 if (re_exec (func_name
))
9464 /* Find the first frame that contains debugging information and that is not
9465 part of the Ada run-time, starting from FI and moving upward. */
9468 ada_find_printable_frame (struct frame_info
*fi
)
9470 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
9472 if (!is_known_support_routine (fi
))
9481 /* Assuming that the inferior just triggered an unhandled exception
9482 catchpoint, return the address in inferior memory where the name
9483 of the exception is stored.
9485 Return zero if the address could not be computed. */
9488 ada_unhandled_exception_name_addr (void)
9490 return parse_and_eval_address ("e.full_name");
9493 /* Same as ada_unhandled_exception_name_addr, except that this function
9494 should be used when the inferior uses an older version of the runtime,
9495 where the exception name needs to be extracted from a specific frame
9496 several frames up in the callstack. */
9499 ada_unhandled_exception_name_addr_from_raise (void)
9502 struct frame_info
*fi
;
9504 /* To determine the name of this exception, we need to select
9505 the frame corresponding to RAISE_SYM_NAME. This frame is
9506 at least 3 levels up, so we simply skip the first 3 frames
9507 without checking the name of their associated function. */
9508 fi
= get_current_frame ();
9509 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
9511 fi
= get_prev_frame (fi
);
9515 const char *func_name
=
9516 function_name_from_pc (get_frame_address_in_block (fi
));
9517 if (func_name
!= NULL
9518 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
9519 break; /* We found the frame we were looking for... */
9520 fi
= get_prev_frame (fi
);
9527 return parse_and_eval_address ("id.full_name");
9530 /* Assuming the inferior just triggered an Ada exception catchpoint
9531 (of any type), return the address in inferior memory where the name
9532 of the exception is stored, if applicable.
9534 Return zero if the address could not be computed, or if not relevant. */
9537 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
9538 struct breakpoint
*b
)
9542 case ex_catch_exception
:
9543 return (parse_and_eval_address ("e.full_name"));
9546 case ex_catch_exception_unhandled
:
9547 return exception_info
->unhandled_exception_name_addr ();
9550 case ex_catch_assert
:
9551 return 0; /* Exception name is not relevant in this case. */
9555 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9559 return 0; /* Should never be reached. */
9562 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
9563 any error that ada_exception_name_addr_1 might cause to be thrown.
9564 When an error is intercepted, a warning with the error message is printed,
9565 and zero is returned. */
9568 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
9569 struct breakpoint
*b
)
9571 struct gdb_exception e
;
9572 CORE_ADDR result
= 0;
9574 TRY_CATCH (e
, RETURN_MASK_ERROR
)
9576 result
= ada_exception_name_addr_1 (ex
, b
);
9581 warning (_("failed to get exception name: %s"), e
.message
);
9588 /* Implement the PRINT_IT method in the breakpoint_ops structure
9589 for all exception catchpoint kinds. */
9591 static enum print_stop_action
9592 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
9594 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
9595 char exception_name
[256];
9599 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
9600 exception_name
[sizeof (exception_name
) - 1] = '\0';
9603 ada_find_printable_frame (get_current_frame ());
9605 annotate_catchpoint (b
->number
);
9608 case ex_catch_exception
:
9610 printf_filtered (_("\nCatchpoint %d, %s at "),
9611 b
->number
, exception_name
);
9613 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
9615 case ex_catch_exception_unhandled
:
9617 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
9618 b
->number
, exception_name
);
9620 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
9623 case ex_catch_assert
:
9624 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
9629 return PRINT_SRC_AND_LOC
;
9632 /* Implement the PRINT_ONE method in the breakpoint_ops structure
9633 for all exception catchpoint kinds. */
9636 print_one_exception (enum exception_catchpoint_kind ex
,
9637 struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9642 ui_out_field_core_addr (uiout
, "addr", b
->loc
->address
);
9646 *last_addr
= b
->loc
->address
;
9649 case ex_catch_exception
:
9650 if (b
->exp_string
!= NULL
)
9652 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
9654 ui_out_field_string (uiout
, "what", msg
);
9658 ui_out_field_string (uiout
, "what", "all Ada exceptions");
9662 case ex_catch_exception_unhandled
:
9663 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
9666 case ex_catch_assert
:
9667 ui_out_field_string (uiout
, "what", "failed Ada assertions");
9671 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9676 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
9677 for all exception catchpoint kinds. */
9680 print_mention_exception (enum exception_catchpoint_kind ex
,
9681 struct breakpoint
*b
)
9685 case ex_catch_exception
:
9686 if (b
->exp_string
!= NULL
)
9687 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
9688 b
->number
, b
->exp_string
);
9690 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
9694 case ex_catch_exception_unhandled
:
9695 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
9699 case ex_catch_assert
:
9700 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
9704 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9709 /* Virtual table for "catch exception" breakpoints. */
9711 static enum print_stop_action
9712 print_it_catch_exception (struct breakpoint
*b
)
9714 return print_it_exception (ex_catch_exception
, b
);
9718 print_one_catch_exception (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9720 print_one_exception (ex_catch_exception
, b
, last_addr
);
9724 print_mention_catch_exception (struct breakpoint
*b
)
9726 print_mention_exception (ex_catch_exception
, b
);
9729 static struct breakpoint_ops catch_exception_breakpoint_ops
=
9731 print_it_catch_exception
,
9732 print_one_catch_exception
,
9733 print_mention_catch_exception
9736 /* Virtual table for "catch exception unhandled" breakpoints. */
9738 static enum print_stop_action
9739 print_it_catch_exception_unhandled (struct breakpoint
*b
)
9741 return print_it_exception (ex_catch_exception_unhandled
, b
);
9745 print_one_catch_exception_unhandled (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9747 print_one_exception (ex_catch_exception_unhandled
, b
, last_addr
);
9751 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
9753 print_mention_exception (ex_catch_exception_unhandled
, b
);
9756 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
9757 print_it_catch_exception_unhandled
,
9758 print_one_catch_exception_unhandled
,
9759 print_mention_catch_exception_unhandled
9762 /* Virtual table for "catch assert" breakpoints. */
9764 static enum print_stop_action
9765 print_it_catch_assert (struct breakpoint
*b
)
9767 return print_it_exception (ex_catch_assert
, b
);
9771 print_one_catch_assert (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9773 print_one_exception (ex_catch_assert
, b
, last_addr
);
9777 print_mention_catch_assert (struct breakpoint
*b
)
9779 print_mention_exception (ex_catch_assert
, b
);
9782 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
9783 print_it_catch_assert
,
9784 print_one_catch_assert
,
9785 print_mention_catch_assert
9788 /* Return non-zero if B is an Ada exception catchpoint. */
9791 ada_exception_catchpoint_p (struct breakpoint
*b
)
9793 return (b
->ops
== &catch_exception_breakpoint_ops
9794 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
9795 || b
->ops
== &catch_assert_breakpoint_ops
);
9798 /* Return a newly allocated copy of the first space-separated token
9799 in ARGSP, and then adjust ARGSP to point immediately after that
9802 Return NULL if ARGPS does not contain any more tokens. */
9805 ada_get_next_arg (char **argsp
)
9807 char *args
= *argsp
;
9811 /* Skip any leading white space. */
9813 while (isspace (*args
))
9816 if (args
[0] == '\0')
9817 return NULL
; /* No more arguments. */
9819 /* Find the end of the current argument. */
9822 while (*end
!= '\0' && !isspace (*end
))
9825 /* Adjust ARGSP to point to the start of the next argument. */
9829 /* Make a copy of the current argument and return it. */
9831 result
= xmalloc (end
- args
+ 1);
9832 strncpy (result
, args
, end
- args
);
9833 result
[end
- args
] = '\0';
9838 /* Split the arguments specified in a "catch exception" command.
9839 Set EX to the appropriate catchpoint type.
9840 Set EXP_STRING to the name of the specific exception if
9841 specified by the user. */
9844 catch_ada_exception_command_split (char *args
,
9845 enum exception_catchpoint_kind
*ex
,
9848 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
9849 char *exception_name
;
9851 exception_name
= ada_get_next_arg (&args
);
9852 make_cleanup (xfree
, exception_name
);
9854 /* Check that we do not have any more arguments. Anything else
9857 while (isspace (*args
))
9860 if (args
[0] != '\0')
9861 error (_("Junk at end of expression"));
9863 discard_cleanups (old_chain
);
9865 if (exception_name
== NULL
)
9867 /* Catch all exceptions. */
9868 *ex
= ex_catch_exception
;
9871 else if (strcmp (exception_name
, "unhandled") == 0)
9873 /* Catch unhandled exceptions. */
9874 *ex
= ex_catch_exception_unhandled
;
9879 /* Catch a specific exception. */
9880 *ex
= ex_catch_exception
;
9881 *exp_string
= exception_name
;
9885 /* Return the name of the symbol on which we should break in order to
9886 implement a catchpoint of the EX kind. */
9889 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
9891 gdb_assert (exception_info
!= NULL
);
9895 case ex_catch_exception
:
9896 return (exception_info
->catch_exception_sym
);
9898 case ex_catch_exception_unhandled
:
9899 return (exception_info
->catch_exception_unhandled_sym
);
9901 case ex_catch_assert
:
9902 return (exception_info
->catch_assert_sym
);
9905 internal_error (__FILE__
, __LINE__
,
9906 _("unexpected catchpoint kind (%d)"), ex
);
9910 /* Return the breakpoint ops "virtual table" used for catchpoints
9913 static struct breakpoint_ops
*
9914 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
9918 case ex_catch_exception
:
9919 return (&catch_exception_breakpoint_ops
);
9921 case ex_catch_exception_unhandled
:
9922 return (&catch_exception_unhandled_breakpoint_ops
);
9924 case ex_catch_assert
:
9925 return (&catch_assert_breakpoint_ops
);
9928 internal_error (__FILE__
, __LINE__
,
9929 _("unexpected catchpoint kind (%d)"), ex
);
9933 /* Return the condition that will be used to match the current exception
9934 being raised with the exception that the user wants to catch. This
9935 assumes that this condition is used when the inferior just triggered
9936 an exception catchpoint.
9938 The string returned is a newly allocated string that needs to be
9939 deallocated later. */
9942 ada_exception_catchpoint_cond_string (const char *exp_string
)
9944 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
9947 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
9949 static struct expression
*
9950 ada_parse_catchpoint_condition (char *cond_string
,
9951 struct symtab_and_line sal
)
9953 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
9956 /* Return the symtab_and_line that should be used to insert an exception
9957 catchpoint of the TYPE kind.
9959 EX_STRING should contain the name of a specific exception
9960 that the catchpoint should catch, or NULL otherwise.
9962 The idea behind all the remaining parameters is that their names match
9963 the name of certain fields in the breakpoint structure that are used to
9964 handle exception catchpoints. This function returns the value to which
9965 these fields should be set, depending on the type of catchpoint we need
9968 If COND and COND_STRING are both non-NULL, any value they might
9969 hold will be free'ed, and then replaced by newly allocated ones.
9970 These parameters are left untouched otherwise. */
9972 static struct symtab_and_line
9973 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
9974 char **addr_string
, char **cond_string
,
9975 struct expression
**cond
, struct breakpoint_ops
**ops
)
9977 const char *sym_name
;
9979 struct symtab_and_line sal
;
9981 /* First, find out which exception support info to use. */
9982 ada_exception_support_info_sniffer ();
9984 /* Then lookup the function on which we will break in order to catch
9985 the Ada exceptions requested by the user. */
9987 sym_name
= ada_exception_sym_name (ex
);
9988 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
9990 /* The symbol we're looking up is provided by a unit in the GNAT runtime
9991 that should be compiled with debugging information. As a result, we
9992 expect to find that symbol in the symtabs. If we don't find it, then
9993 the target most likely does not support Ada exceptions, or we cannot
9994 insert exception breakpoints yet, because the GNAT runtime hasn't been
9997 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
9998 in such a way that no debugging information is produced for the symbol
9999 we are looking for. In this case, we could search the minimal symbols
10000 as a fall-back mechanism. This would still be operating in degraded
10001 mode, however, as we would still be missing the debugging information
10002 that is needed in order to extract the name of the exception being
10003 raised (this name is printed in the catchpoint message, and is also
10004 used when trying to catch a specific exception). We do not handle
10005 this case for now. */
10008 error (_("Unable to break on '%s' in this configuration."), sym_name
);
10010 /* Make sure that the symbol we found corresponds to a function. */
10011 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
10012 error (_("Symbol \"%s\" is not a function (class = %d)"),
10013 sym_name
, SYMBOL_CLASS (sym
));
10015 sal
= find_function_start_sal (sym
, 1);
10017 /* Set ADDR_STRING. */
10019 *addr_string
= xstrdup (sym_name
);
10021 /* Set the COND and COND_STRING (if not NULL). */
10023 if (cond_string
!= NULL
&& cond
!= NULL
)
10025 if (*cond_string
!= NULL
)
10027 xfree (*cond_string
);
10028 *cond_string
= NULL
;
10035 if (exp_string
!= NULL
)
10037 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
10038 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
10043 *ops
= ada_exception_breakpoint_ops (ex
);
10048 /* Parse the arguments (ARGS) of the "catch exception" command.
10050 Set TYPE to the appropriate exception catchpoint type.
10051 If the user asked the catchpoint to catch only a specific
10052 exception, then save the exception name in ADDR_STRING.
10054 See ada_exception_sal for a description of all the remaining
10055 function arguments of this function. */
10057 struct symtab_and_line
10058 ada_decode_exception_location (char *args
, char **addr_string
,
10059 char **exp_string
, char **cond_string
,
10060 struct expression
**cond
,
10061 struct breakpoint_ops
**ops
)
10063 enum exception_catchpoint_kind ex
;
10065 catch_ada_exception_command_split (args
, &ex
, exp_string
);
10066 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
10070 struct symtab_and_line
10071 ada_decode_assert_location (char *args
, char **addr_string
,
10072 struct breakpoint_ops
**ops
)
10074 /* Check that no argument where provided at the end of the command. */
10078 while (isspace (*args
))
10081 error (_("Junk at end of arguments."));
10084 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
10089 /* Information about operators given special treatment in functions
10091 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10093 #define ADA_OPERATORS \
10094 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10095 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10096 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10097 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10098 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10099 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10100 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10101 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10102 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10103 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10104 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10105 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10106 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10107 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10108 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10109 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10110 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10111 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10112 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10115 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
10117 switch (exp
->elts
[pc
- 1].opcode
)
10120 operator_length_standard (exp
, pc
, oplenp
, argsp
);
10123 #define OP_DEFN(op, len, args, binop) \
10124 case op: *oplenp = len; *argsp = args; break;
10130 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
10135 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
10141 ada_op_name (enum exp_opcode opcode
)
10146 return op_name_standard (opcode
);
10148 #define OP_DEFN(op, len, args, binop) case op: return #op;
10153 return "OP_AGGREGATE";
10155 return "OP_CHOICES";
10161 /* As for operator_length, but assumes PC is pointing at the first
10162 element of the operator, and gives meaningful results only for the
10163 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10166 ada_forward_operator_length (struct expression
*exp
, int pc
,
10167 int *oplenp
, int *argsp
)
10169 switch (exp
->elts
[pc
].opcode
)
10172 *oplenp
= *argsp
= 0;
10175 #define OP_DEFN(op, len, args, binop) \
10176 case op: *oplenp = len; *argsp = args; break;
10182 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10187 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
10193 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10194 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
10202 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
10204 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
10209 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
10213 /* Ada attributes ('Foo). */
10216 case OP_ATR_LENGTH
:
10220 case OP_ATR_MODULUS
:
10227 case UNOP_IN_RANGE
:
10229 /* XXX: gdb_sprint_host_address, type_sprint */
10230 fprintf_filtered (stream
, _("Type @"));
10231 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
10232 fprintf_filtered (stream
, " (");
10233 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
10234 fprintf_filtered (stream
, ")");
10236 case BINOP_IN_BOUNDS
:
10237 fprintf_filtered (stream
, " (%d)",
10238 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
10240 case TERNOP_IN_RANGE
:
10245 case OP_DISCRETE_RANGE
:
10246 case OP_POSITIONAL
:
10253 char *name
= &exp
->elts
[elt
+ 2].string
;
10254 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
10255 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
10260 return dump_subexp_body_standard (exp
, stream
, elt
);
10264 for (i
= 0; i
< nargs
; i
+= 1)
10265 elt
= dump_subexp (exp
, stream
, elt
);
10270 /* The Ada extension of print_subexp (q.v.). */
10273 ada_print_subexp (struct expression
*exp
, int *pos
,
10274 struct ui_file
*stream
, enum precedence prec
)
10276 int oplen
, nargs
, i
;
10278 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
10280 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10287 print_subexp_standard (exp
, pos
, stream
, prec
);
10291 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
10294 case BINOP_IN_BOUNDS
:
10295 /* XXX: sprint_subexp */
10296 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10297 fputs_filtered (" in ", stream
);
10298 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10299 fputs_filtered ("'range", stream
);
10300 if (exp
->elts
[pc
+ 1].longconst
> 1)
10301 fprintf_filtered (stream
, "(%ld)",
10302 (long) exp
->elts
[pc
+ 1].longconst
);
10305 case TERNOP_IN_RANGE
:
10306 if (prec
>= PREC_EQUAL
)
10307 fputs_filtered ("(", stream
);
10308 /* XXX: sprint_subexp */
10309 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10310 fputs_filtered (" in ", stream
);
10311 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10312 fputs_filtered (" .. ", stream
);
10313 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10314 if (prec
>= PREC_EQUAL
)
10315 fputs_filtered (")", stream
);
10320 case OP_ATR_LENGTH
:
10324 case OP_ATR_MODULUS
:
10329 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10331 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10332 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10336 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10337 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10341 for (tem
= 1; tem
< nargs
; tem
+= 1)
10343 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10344 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10346 fputs_filtered (")", stream
);
10351 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10352 fputs_filtered ("'(", stream
);
10353 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10354 fputs_filtered (")", stream
);
10357 case UNOP_IN_RANGE
:
10358 /* XXX: sprint_subexp */
10359 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10360 fputs_filtered (" in ", stream
);
10361 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10364 case OP_DISCRETE_RANGE
:
10365 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10366 fputs_filtered ("..", stream
);
10367 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10371 fputs_filtered ("others => ", stream
);
10372 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10376 for (i
= 0; i
< nargs
-1; i
+= 1)
10379 fputs_filtered ("|", stream
);
10380 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10382 fputs_filtered (" => ", stream
);
10383 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10386 case OP_POSITIONAL
:
10387 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10391 fputs_filtered ("(", stream
);
10392 for (i
= 0; i
< nargs
; i
+= 1)
10395 fputs_filtered (", ", stream
);
10396 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10398 fputs_filtered (")", stream
);
10403 /* Table mapping opcodes into strings for printing operators
10404 and precedences of the operators. */
10406 static const struct op_print ada_op_print_tab
[] = {
10407 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10408 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10409 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10410 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10411 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10412 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10413 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10414 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10415 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10416 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10417 {">", BINOP_GTR
, PREC_ORDER
, 0},
10418 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10419 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10420 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10421 {"+", BINOP_ADD
, PREC_ADD
, 0},
10422 {"-", BINOP_SUB
, PREC_ADD
, 0},
10423 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10424 {"*", BINOP_MUL
, PREC_MUL
, 0},
10425 {"/", BINOP_DIV
, PREC_MUL
, 0},
10426 {"rem", BINOP_REM
, PREC_MUL
, 0},
10427 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10428 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10429 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10430 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10431 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10432 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10433 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10434 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10435 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10436 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10437 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10441 enum ada_primitive_types
{
10442 ada_primitive_type_int
,
10443 ada_primitive_type_long
,
10444 ada_primitive_type_short
,
10445 ada_primitive_type_char
,
10446 ada_primitive_type_float
,
10447 ada_primitive_type_double
,
10448 ada_primitive_type_void
,
10449 ada_primitive_type_long_long
,
10450 ada_primitive_type_long_double
,
10451 ada_primitive_type_natural
,
10452 ada_primitive_type_positive
,
10453 ada_primitive_type_system_address
,
10454 nr_ada_primitive_types
10458 ada_language_arch_info (struct gdbarch
*gdbarch
,
10459 struct language_arch_info
*lai
)
10461 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
10462 lai
->primitive_type_vector
10463 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
10465 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10466 init_type (TYPE_CODE_INT
,
10467 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10468 0, "integer", (struct objfile
*) NULL
);
10469 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10470 init_type (TYPE_CODE_INT
,
10471 gdbarch_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10472 0, "long_integer", (struct objfile
*) NULL
);
10473 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10474 init_type (TYPE_CODE_INT
,
10475 gdbarch_short_bit (gdbarch
) / TARGET_CHAR_BIT
,
10476 0, "short_integer", (struct objfile
*) NULL
);
10477 lai
->string_char_type
=
10478 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10479 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10480 0, "character", (struct objfile
*) NULL
);
10481 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10482 init_type (TYPE_CODE_FLT
,
10483 gdbarch_float_bit (gdbarch
)/ TARGET_CHAR_BIT
,
10484 0, "float", (struct objfile
*) NULL
);
10485 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10486 init_type (TYPE_CODE_FLT
,
10487 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10488 0, "long_float", (struct objfile
*) NULL
);
10489 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10490 init_type (TYPE_CODE_INT
,
10491 gdbarch_long_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10492 0, "long_long_integer", (struct objfile
*) NULL
);
10493 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10494 init_type (TYPE_CODE_FLT
,
10495 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10496 0, "long_long_float", (struct objfile
*) NULL
);
10497 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10498 init_type (TYPE_CODE_INT
,
10499 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10500 0, "natural", (struct objfile
*) NULL
);
10501 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10502 init_type (TYPE_CODE_INT
,
10503 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10504 0, "positive", (struct objfile
*) NULL
);
10505 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10507 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10508 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10509 (struct objfile
*) NULL
));
10510 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
10511 = "system__address";
10514 /* Language vector */
10516 /* Not really used, but needed in the ada_language_defn. */
10519 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10521 ada_emit_char (c
, stream
, quoter
, 1);
10527 warnings_issued
= 0;
10528 return ada_parse ();
10531 static const struct exp_descriptor ada_exp_descriptor
= {
10533 ada_operator_length
,
10535 ada_dump_subexp_body
,
10536 ada_evaluate_subexp
10539 const struct language_defn ada_language_defn
= {
10540 "ada", /* Language name */
10544 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
10545 that's not quite what this means. */
10547 &ada_exp_descriptor
,
10551 ada_printchar
, /* Print a character constant */
10552 ada_printstr
, /* Function to print string constant */
10553 emit_char
, /* Function to print single char (not used) */
10554 ada_print_type
, /* Print a type using appropriate syntax */
10555 ada_val_print
, /* Print a value using appropriate syntax */
10556 ada_value_print
, /* Print a top-level value */
10557 NULL
, /* Language specific skip_trampoline */
10558 NULL
, /* value_of_this */
10559 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
10560 basic_lookup_transparent_type
, /* lookup_transparent_type */
10561 ada_la_decode
, /* Language specific symbol demangler */
10562 NULL
, /* Language specific class_name_from_physname */
10563 ada_op_print_tab
, /* expression operators for printing */
10564 0, /* c-style arrays */
10565 1, /* String lower bound */
10566 ada_get_gdb_completer_word_break_characters
,
10567 ada_language_arch_info
,
10568 ada_print_array_index
,
10569 default_pass_by_reference
,
10574 _initialize_ada_language (void)
10576 add_language (&ada_language_defn
);
10578 varsize_limit
= 65536;
10580 obstack_init (&symbol_list_obstack
);
10582 decoded_names_store
= htab_create_alloc
10583 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
10584 NULL
, xcalloc
, xfree
);
10586 observer_attach_executable_changed (ada_executable_changed_observer
);