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 return value_cast (value_type (arg1
), value_add (arg1
, arg2
));
8136 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8137 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8138 if (noside
== EVAL_SKIP
)
8140 if ((ada_is_fixed_point_type (value_type (arg1
))
8141 || ada_is_fixed_point_type (value_type (arg2
)))
8142 && value_type (arg1
) != value_type (arg2
))
8143 error (_("Operands of fixed-point subtraction must have the same type"));
8144 return value_cast (value_type (arg1
), value_sub (arg1
, arg2
));
8148 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8149 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8150 if (noside
== EVAL_SKIP
)
8152 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8153 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8154 return value_zero (value_type (arg1
), not_lval
);
8157 if (ada_is_fixed_point_type (value_type (arg1
)))
8158 arg1
= cast_from_fixed_to_double (arg1
);
8159 if (ada_is_fixed_point_type (value_type (arg2
)))
8160 arg2
= cast_from_fixed_to_double (arg2
);
8161 return ada_value_binop (arg1
, arg2
, op
);
8166 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8167 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8168 if (noside
== EVAL_SKIP
)
8170 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8171 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8172 return value_zero (value_type (arg1
), not_lval
);
8174 return ada_value_binop (arg1
, arg2
, op
);
8177 case BINOP_NOTEQUAL
:
8178 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8179 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8180 if (noside
== EVAL_SKIP
)
8182 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8185 tem
= ada_value_equal (arg1
, arg2
);
8186 if (op
== BINOP_NOTEQUAL
)
8188 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
8191 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8192 if (noside
== EVAL_SKIP
)
8194 else if (ada_is_fixed_point_type (value_type (arg1
)))
8195 return value_cast (value_type (arg1
), value_neg (arg1
));
8197 return value_neg (arg1
);
8199 case BINOP_LOGICAL_AND
:
8200 case BINOP_LOGICAL_OR
:
8201 case UNOP_LOGICAL_NOT
:
8206 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8207 return value_cast (LA_BOOL_TYPE
, val
);
8210 case BINOP_BITWISE_AND
:
8211 case BINOP_BITWISE_IOR
:
8212 case BINOP_BITWISE_XOR
:
8216 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8218 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8220 return value_cast (value_type (arg1
), val
);
8225 if (noside
== EVAL_SKIP
)
8230 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8231 /* Only encountered when an unresolved symbol occurs in a
8232 context other than a function call, in which case, it is
8234 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8235 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8236 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8240 (to_static_fixed_type
8241 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8247 unwrap_value (evaluate_subexp_standard
8248 (expect_type
, exp
, pos
, noside
));
8249 return ada_to_fixed_value (arg1
);
8255 /* Allocate arg vector, including space for the function to be
8256 called in argvec[0] and a terminating NULL. */
8257 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8259 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8261 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8262 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8263 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8264 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8267 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8268 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8271 if (noside
== EVAL_SKIP
)
8275 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
8276 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8277 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
8278 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
8279 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8280 argvec
[0] = value_addr (argvec
[0]);
8282 type
= ada_check_typedef (value_type (argvec
[0]));
8283 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8285 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
8287 case TYPE_CODE_FUNC
:
8288 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8290 case TYPE_CODE_ARRAY
:
8292 case TYPE_CODE_STRUCT
:
8293 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8294 argvec
[0] = ada_value_ind (argvec
[0]);
8295 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8298 error (_("cannot subscript or call something of type `%s'"),
8299 ada_type_name (value_type (argvec
[0])));
8304 switch (TYPE_CODE (type
))
8306 case TYPE_CODE_FUNC
:
8307 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8308 return allocate_value (TYPE_TARGET_TYPE (type
));
8309 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8310 case TYPE_CODE_STRUCT
:
8314 arity
= ada_array_arity (type
);
8315 type
= ada_array_element_type (type
, nargs
);
8317 error (_("cannot subscript or call a record"));
8319 error (_("wrong number of subscripts; expecting %d"), arity
);
8320 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8321 return allocate_value (ada_aligned_type (type
));
8323 unwrap_value (ada_value_subscript
8324 (argvec
[0], nargs
, argvec
+ 1));
8326 case TYPE_CODE_ARRAY
:
8327 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8329 type
= ada_array_element_type (type
, nargs
);
8331 error (_("element type of array unknown"));
8333 return allocate_value (ada_aligned_type (type
));
8336 unwrap_value (ada_value_subscript
8337 (ada_coerce_to_simple_array (argvec
[0]),
8338 nargs
, argvec
+ 1));
8339 case TYPE_CODE_PTR
: /* Pointer to array */
8340 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8341 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8343 type
= ada_array_element_type (type
, nargs
);
8345 error (_("element type of array unknown"));
8347 return allocate_value (ada_aligned_type (type
));
8350 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8351 nargs
, argvec
+ 1));
8354 error (_("Attempt to index or call something other than an "
8355 "array or function"));
8360 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8361 struct value
*low_bound_val
=
8362 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8363 struct value
*high_bound_val
=
8364 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8367 low_bound_val
= coerce_ref (low_bound_val
);
8368 high_bound_val
= coerce_ref (high_bound_val
);
8369 low_bound
= pos_atr (low_bound_val
);
8370 high_bound
= pos_atr (high_bound_val
);
8372 if (noside
== EVAL_SKIP
)
8375 /* If this is a reference to an aligner type, then remove all
8377 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8378 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
8379 TYPE_TARGET_TYPE (value_type (array
)) =
8380 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
8382 if (ada_is_packed_array_type (value_type (array
)))
8383 error (_("cannot slice a packed array"));
8385 /* If this is a reference to an array or an array lvalue,
8386 convert to a pointer. */
8387 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8388 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
8389 && VALUE_LVAL (array
) == lval_memory
))
8390 array
= value_addr (array
);
8392 if (noside
== EVAL_AVOID_SIDE_EFFECTS
8393 && ada_is_array_descriptor_type (ada_check_typedef
8394 (value_type (array
))))
8395 return empty_array (ada_type_of_array (array
, 0), low_bound
);
8397 array
= ada_coerce_to_simple_array_ptr (array
);
8399 /* If we have more than one level of pointer indirection,
8400 dereference the value until we get only one level. */
8401 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
8402 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
8404 array
= value_ind (array
);
8406 /* Make sure we really do have an array type before going further,
8407 to avoid a SEGV when trying to get the index type or the target
8408 type later down the road if the debug info generated by
8409 the compiler is incorrect or incomplete. */
8410 if (!ada_is_simple_array_type (value_type (array
)))
8411 error (_("cannot take slice of non-array"));
8413 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
8415 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8416 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
8420 struct type
*arr_type0
=
8421 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
8423 return ada_value_slice_ptr (array
, arr_type0
,
8424 longest_to_int (low_bound
),
8425 longest_to_int (high_bound
));
8428 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8430 else if (high_bound
< low_bound
)
8431 return empty_array (value_type (array
), low_bound
);
8433 return ada_value_slice (array
, longest_to_int (low_bound
),
8434 longest_to_int (high_bound
));
8439 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8440 type
= exp
->elts
[pc
+ 1].type
;
8442 if (noside
== EVAL_SKIP
)
8445 switch (TYPE_CODE (type
))
8448 lim_warning (_("Membership test incompletely implemented; "
8449 "always returns true"));
8450 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
8452 case TYPE_CODE_RANGE
:
8453 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
8454 arg3
= value_from_longest (builtin_type_int
,
8455 TYPE_HIGH_BOUND (type
));
8457 value_from_longest (builtin_type_int
,
8458 (value_less (arg1
, arg3
)
8459 || value_equal (arg1
, arg3
))
8460 && (value_less (arg2
, arg1
)
8461 || value_equal (arg2
, arg1
)));
8464 case BINOP_IN_BOUNDS
:
8466 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8467 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8469 if (noside
== EVAL_SKIP
)
8472 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8473 return value_zero (builtin_type_int
, not_lval
);
8475 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8477 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
8478 error (_("invalid dimension number to 'range"));
8480 arg3
= ada_array_bound (arg2
, tem
, 1);
8481 arg2
= ada_array_bound (arg2
, tem
, 0);
8484 value_from_longest (builtin_type_int
,
8485 (value_less (arg1
, arg3
)
8486 || value_equal (arg1
, arg3
))
8487 && (value_less (arg2
, arg1
)
8488 || value_equal (arg2
, arg1
)));
8490 case TERNOP_IN_RANGE
:
8491 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8492 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8493 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8495 if (noside
== EVAL_SKIP
)
8499 value_from_longest (builtin_type_int
,
8500 (value_less (arg1
, arg3
)
8501 || value_equal (arg1
, arg3
))
8502 && (value_less (arg2
, arg1
)
8503 || value_equal (arg2
, arg1
)));
8509 struct type
*type_arg
;
8510 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8512 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8514 type_arg
= exp
->elts
[pc
+ 2].type
;
8518 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8522 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
8523 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
8524 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
8527 if (noside
== EVAL_SKIP
)
8530 if (type_arg
== NULL
)
8532 arg1
= ada_coerce_ref (arg1
);
8534 if (ada_is_packed_array_type (value_type (arg1
)))
8535 arg1
= ada_coerce_to_simple_array (arg1
);
8537 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
8538 error (_("invalid dimension number to '%s"),
8539 ada_attribute_name (op
));
8541 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8543 type
= ada_index_type (value_type (arg1
), tem
);
8546 (_("attempt to take bound of something that is not an array"));
8547 return allocate_value (type
);
8552 default: /* Should never happen. */
8553 error (_("unexpected attribute encountered"));
8555 return ada_array_bound (arg1
, tem
, 0);
8557 return ada_array_bound (arg1
, tem
, 1);
8559 return ada_array_length (arg1
, tem
);
8562 else if (discrete_type_p (type_arg
))
8564 struct type
*range_type
;
8565 char *name
= ada_type_name (type_arg
);
8567 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
8569 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
8570 if (range_type
== NULL
)
8571 range_type
= type_arg
;
8575 error (_("unexpected attribute encountered"));
8577 return discrete_type_low_bound (range_type
);
8579 return discrete_type_high_bound (range_type
);
8581 error (_("the 'length attribute applies only to array types"));
8584 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
8585 error (_("unimplemented type attribute"));
8590 if (ada_is_packed_array_type (type_arg
))
8591 type_arg
= decode_packed_array_type (type_arg
);
8593 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
8594 error (_("invalid dimension number to '%s"),
8595 ada_attribute_name (op
));
8597 type
= ada_index_type (type_arg
, tem
);
8600 (_("attempt to take bound of something that is not an array"));
8601 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8602 return allocate_value (type
);
8607 error (_("unexpected attribute encountered"));
8609 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
8610 return value_from_longest (type
, low
);
8612 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
8613 return value_from_longest (type
, high
);
8615 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
8616 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
8617 return value_from_longest (type
, high
- low
+ 1);
8623 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8624 if (noside
== EVAL_SKIP
)
8627 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8628 return value_zero (ada_tag_type (arg1
), not_lval
);
8630 return ada_value_tag (arg1
);
8634 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8635 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8636 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8637 if (noside
== EVAL_SKIP
)
8639 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8640 return value_zero (value_type (arg1
), not_lval
);
8642 return value_binop (arg1
, arg2
,
8643 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
8645 case OP_ATR_MODULUS
:
8647 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
8648 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8650 if (noside
== EVAL_SKIP
)
8653 if (!ada_is_modular_type (type_arg
))
8654 error (_("'modulus must be applied to modular type"));
8656 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
8657 ada_modulus (type_arg
));
8662 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8663 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8664 if (noside
== EVAL_SKIP
)
8666 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8667 return value_zero (builtin_type_int
, not_lval
);
8669 return value_pos_atr (arg1
);
8672 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8673 if (noside
== EVAL_SKIP
)
8675 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8676 return value_zero (builtin_type_int
, not_lval
);
8678 return value_from_longest (builtin_type_int
,
8680 * TYPE_LENGTH (value_type (arg1
)));
8683 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8684 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8685 type
= exp
->elts
[pc
+ 2].type
;
8686 if (noside
== EVAL_SKIP
)
8688 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8689 return value_zero (type
, not_lval
);
8691 return value_val_atr (type
, arg1
);
8694 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8695 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8696 if (noside
== EVAL_SKIP
)
8698 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8699 return value_zero (value_type (arg1
), not_lval
);
8701 return value_binop (arg1
, arg2
, op
);
8704 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8705 if (noside
== EVAL_SKIP
)
8711 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8712 if (noside
== EVAL_SKIP
)
8714 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
8715 return value_neg (arg1
);
8720 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
8721 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
8722 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
8723 if (noside
== EVAL_SKIP
)
8725 type
= ada_check_typedef (value_type (arg1
));
8726 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8728 if (ada_is_array_descriptor_type (type
))
8729 /* GDB allows dereferencing GNAT array descriptors. */
8731 struct type
*arrType
= ada_type_of_array (arg1
, 0);
8732 if (arrType
== NULL
)
8733 error (_("Attempt to dereference null array pointer."));
8734 return value_at_lazy (arrType
, 0);
8736 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
8737 || TYPE_CODE (type
) == TYPE_CODE_REF
8738 /* In C you can dereference an array to get the 1st elt. */
8739 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8741 type
= to_static_fixed_type
8743 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
8745 return value_zero (type
, lval_memory
);
8747 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
8748 /* GDB allows dereferencing an int. */
8749 return value_zero (builtin_type_int
, lval_memory
);
8751 error (_("Attempt to take contents of a non-pointer value."));
8753 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
8754 type
= ada_check_typedef (value_type (arg1
));
8756 if (ada_is_array_descriptor_type (type
))
8757 /* GDB allows dereferencing GNAT array descriptors. */
8758 return ada_coerce_to_simple_array (arg1
);
8760 return ada_value_ind (arg1
);
8762 case STRUCTOP_STRUCT
:
8763 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8764 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
8765 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8766 if (noside
== EVAL_SKIP
)
8768 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8770 struct type
*type1
= value_type (arg1
);
8771 if (ada_is_tagged_type (type1
, 1))
8773 type
= ada_lookup_struct_elt_type (type1
,
8774 &exp
->elts
[pc
+ 2].string
,
8777 /* In this case, we assume that the field COULD exist
8778 in some extension of the type. Return an object of
8779 "type" void, which will match any formal
8780 (see ada_type_match). */
8781 return value_zero (builtin_type_void
, lval_memory
);
8785 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
8788 return value_zero (ada_aligned_type (type
), lval_memory
);
8792 ada_to_fixed_value (unwrap_value
8793 (ada_value_struct_elt
8794 (arg1
, &exp
->elts
[pc
+ 2].string
, 0)));
8796 /* The value is not supposed to be used. This is here to make it
8797 easier to accommodate expressions that contain types. */
8799 if (noside
== EVAL_SKIP
)
8801 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8802 return allocate_value (exp
->elts
[pc
+ 1].type
);
8804 error (_("Attempt to use a type name as an expression"));
8809 case OP_DISCRETE_RANGE
:
8812 if (noside
== EVAL_NORMAL
)
8816 error (_("Undefined name, ambiguous name, or renaming used in "
8817 "component association: %s."), &exp
->elts
[pc
+2].string
);
8819 error (_("Aggregates only allowed on the right of an assignment"));
8821 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
8824 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8826 for (tem
= 0; tem
< nargs
; tem
+= 1)
8827 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8832 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
8838 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
8839 type name that encodes the 'small and 'delta information.
8840 Otherwise, return NULL. */
8843 fixed_type_info (struct type
*type
)
8845 const char *name
= ada_type_name (type
);
8846 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
8848 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
8850 const char *tail
= strstr (name
, "___XF_");
8856 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
8857 return fixed_type_info (TYPE_TARGET_TYPE (type
));
8862 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
8865 ada_is_fixed_point_type (struct type
*type
)
8867 return fixed_type_info (type
) != NULL
;
8870 /* Return non-zero iff TYPE represents a System.Address type. */
8873 ada_is_system_address_type (struct type
*type
)
8875 return (TYPE_NAME (type
)
8876 && strcmp (TYPE_NAME (type
), "system__address") == 0);
8879 /* Assuming that TYPE is the representation of an Ada fixed-point
8880 type, return its delta, or -1 if the type is malformed and the
8881 delta cannot be determined. */
8884 ada_delta (struct type
*type
)
8886 const char *encoding
= fixed_type_info (type
);
8889 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
8892 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
8895 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
8896 factor ('SMALL value) associated with the type. */
8899 scaling_factor (struct type
*type
)
8901 const char *encoding
= fixed_type_info (type
);
8902 unsigned long num0
, den0
, num1
, den1
;
8905 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
8910 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
8912 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
8916 /* Assuming that X is the representation of a value of fixed-point
8917 type TYPE, return its floating-point equivalent. */
8920 ada_fixed_to_float (struct type
*type
, LONGEST x
)
8922 return (DOUBLEST
) x
*scaling_factor (type
);
8925 /* The representation of a fixed-point value of type TYPE
8926 corresponding to the value X. */
8929 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
8931 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
8935 /* VAX floating formats */
8937 /* Non-zero iff TYPE represents one of the special VAX floating-point
8941 ada_is_vax_floating_type (struct type
*type
)
8944 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
8947 && (TYPE_CODE (type
) == TYPE_CODE_INT
8948 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8949 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
8952 /* The type of special VAX floating-point type this is, assuming
8953 ada_is_vax_floating_point. */
8956 ada_vax_float_type_suffix (struct type
*type
)
8958 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
8961 /* A value representing the special debugging function that outputs
8962 VAX floating-point values of the type represented by TYPE. Assumes
8963 ada_is_vax_floating_type (TYPE). */
8966 ada_vax_float_print_function (struct type
*type
)
8968 switch (ada_vax_float_type_suffix (type
))
8971 return get_var_value ("DEBUG_STRING_F", 0);
8973 return get_var_value ("DEBUG_STRING_D", 0);
8975 return get_var_value ("DEBUG_STRING_G", 0);
8977 error (_("invalid VAX floating-point type"));
8984 /* Scan STR beginning at position K for a discriminant name, and
8985 return the value of that discriminant field of DVAL in *PX. If
8986 PNEW_K is not null, put the position of the character beyond the
8987 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8988 not alter *PX and *PNEW_K if unsuccessful. */
8991 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
8994 static char *bound_buffer
= NULL
;
8995 static size_t bound_buffer_len
= 0;
8998 struct value
*bound_val
;
9000 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9003 pend
= strstr (str
+ k
, "__");
9007 k
+= strlen (bound
);
9011 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9012 bound
= bound_buffer
;
9013 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9014 bound
[pend
- (str
+ k
)] = '\0';
9018 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9019 if (bound_val
== NULL
)
9022 *px
= value_as_long (bound_val
);
9028 /* Value of variable named NAME in the current environment. If
9029 no such variable found, then if ERR_MSG is null, returns 0, and
9030 otherwise causes an error with message ERR_MSG. */
9032 static struct value
*
9033 get_var_value (char *name
, char *err_msg
)
9035 struct ada_symbol_info
*syms
;
9038 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9043 if (err_msg
== NULL
)
9046 error (("%s"), err_msg
);
9049 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9052 /* Value of integer variable named NAME in the current environment. If
9053 no such variable found, returns 0, and sets *FLAG to 0. If
9054 successful, sets *FLAG to 1. */
9057 get_int_var_value (char *name
, int *flag
)
9059 struct value
*var_val
= get_var_value (name
, 0);
9071 return value_as_long (var_val
);
9076 /* Return a range type whose base type is that of the range type named
9077 NAME in the current environment, and whose bounds are calculated
9078 from NAME according to the GNAT range encoding conventions.
9079 Extract discriminant values, if needed, from DVAL. If a new type
9080 must be created, allocate in OBJFILE's space. The bounds
9081 information, in general, is encoded in NAME, the base type given in
9082 the named range type. */
9084 static struct type
*
9085 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9087 struct type
*raw_type
= ada_find_any_type (name
);
9088 struct type
*base_type
;
9091 if (raw_type
== NULL
)
9092 base_type
= builtin_type_int
;
9093 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9094 base_type
= TYPE_TARGET_TYPE (raw_type
);
9096 base_type
= raw_type
;
9098 subtype_info
= strstr (name
, "___XD");
9099 if (subtype_info
== NULL
)
9103 static char *name_buf
= NULL
;
9104 static size_t name_len
= 0;
9105 int prefix_len
= subtype_info
- name
;
9111 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9112 strncpy (name_buf
, name
, prefix_len
);
9113 name_buf
[prefix_len
] = '\0';
9116 bounds_str
= strchr (subtype_info
, '_');
9119 if (*subtype_info
== 'L')
9121 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9122 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9124 if (bounds_str
[n
] == '_')
9126 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9133 strcpy (name_buf
+ prefix_len
, "___L");
9134 L
= get_int_var_value (name_buf
, &ok
);
9137 lim_warning (_("Unknown lower bound, using 1."));
9142 if (*subtype_info
== 'U')
9144 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9145 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9151 strcpy (name_buf
+ prefix_len
, "___U");
9152 U
= get_int_var_value (name_buf
, &ok
);
9155 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
9160 if (objfile
== NULL
)
9161 objfile
= TYPE_OBJFILE (base_type
);
9162 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9163 TYPE_NAME (type
) = name
;
9168 /* True iff NAME is the name of a range type. */
9171 ada_is_range_type_name (const char *name
)
9173 return (name
!= NULL
&& strstr (name
, "___XD"));
9179 /* True iff TYPE is an Ada modular type. */
9182 ada_is_modular_type (struct type
*type
)
9184 struct type
*subranged_type
= base_type (type
);
9186 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9187 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
9188 && TYPE_UNSIGNED (subranged_type
));
9191 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9194 ada_modulus (struct type
* type
)
9196 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
9200 /* Ada exception catchpoint support:
9201 ---------------------------------
9203 We support 3 kinds of exception catchpoints:
9204 . catchpoints on Ada exceptions
9205 . catchpoints on unhandled Ada exceptions
9206 . catchpoints on failed assertions
9208 Exceptions raised during failed assertions, or unhandled exceptions
9209 could perfectly be caught with the general catchpoint on Ada exceptions.
9210 However, we can easily differentiate these two special cases, and having
9211 the option to distinguish these two cases from the rest can be useful
9212 to zero-in on certain situations.
9214 Exception catchpoints are a specialized form of breakpoint,
9215 since they rely on inserting breakpoints inside known routines
9216 of the GNAT runtime. The implementation therefore uses a standard
9217 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9220 Support in the runtime for exception catchpoints have been changed
9221 a few times already, and these changes affect the implementation
9222 of these catchpoints. In order to be able to support several
9223 variants of the runtime, we use a sniffer that will determine
9224 the runtime variant used by the program being debugged.
9226 At this time, we do not support the use of conditions on Ada exception
9227 catchpoints. The COND and COND_STRING fields are therefore set
9228 to NULL (most of the time, see below).
9230 Conditions where EXP_STRING, COND, and COND_STRING are used:
9232 When a user specifies the name of a specific exception in the case
9233 of catchpoints on Ada exceptions, we store the name of that exception
9234 in the EXP_STRING. We then translate this request into an actual
9235 condition stored in COND_STRING, and then parse it into an expression
9238 /* The different types of catchpoints that we introduced for catching
9241 enum exception_catchpoint_kind
9244 ex_catch_exception_unhandled
,
9248 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
9250 /* A structure that describes how to support exception catchpoints
9251 for a given executable. */
9253 struct exception_support_info
9255 /* The name of the symbol to break on in order to insert
9256 a catchpoint on exceptions. */
9257 const char *catch_exception_sym
;
9259 /* The name of the symbol to break on in order to insert
9260 a catchpoint on unhandled exceptions. */
9261 const char *catch_exception_unhandled_sym
;
9263 /* The name of the symbol to break on in order to insert
9264 a catchpoint on failed assertions. */
9265 const char *catch_assert_sym
;
9267 /* Assuming that the inferior just triggered an unhandled exception
9268 catchpoint, this function is responsible for returning the address
9269 in inferior memory where the name of that exception is stored.
9270 Return zero if the address could not be computed. */
9271 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
9274 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
9275 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
9277 /* The following exception support info structure describes how to
9278 implement exception catchpoints with the latest version of the
9279 Ada runtime (as of 2007-03-06). */
9281 static const struct exception_support_info default_exception_support_info
=
9283 "__gnat_debug_raise_exception", /* catch_exception_sym */
9284 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9285 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9286 ada_unhandled_exception_name_addr
9289 /* The following exception support info structure describes how to
9290 implement exception catchpoints with a slightly older version
9291 of the Ada runtime. */
9293 static const struct exception_support_info exception_support_info_fallback
=
9295 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9296 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9297 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9298 ada_unhandled_exception_name_addr_from_raise
9301 /* For each executable, we sniff which exception info structure to use
9302 and cache it in the following global variable. */
9304 static const struct exception_support_info
*exception_info
= NULL
;
9306 /* Inspect the Ada runtime and determine which exception info structure
9307 should be used to provide support for exception catchpoints.
9309 This function will always set exception_info, or raise an error. */
9312 ada_exception_support_info_sniffer (void)
9316 /* If the exception info is already known, then no need to recompute it. */
9317 if (exception_info
!= NULL
)
9320 /* Check the latest (default) exception support info. */
9321 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
9325 exception_info
= &default_exception_support_info
;
9329 /* Try our fallback exception suport info. */
9330 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
9334 exception_info
= &exception_support_info_fallback
;
9338 /* Sometimes, it is normal for us to not be able to find the routine
9339 we are looking for. This happens when the program is linked with
9340 the shared version of the GNAT runtime, and the program has not been
9341 started yet. Inform the user of these two possible causes if
9344 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
9345 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9347 /* If the symbol does not exist, then check that the program is
9348 already started, to make sure that shared libraries have been
9349 loaded. If it is not started, this may mean that the symbol is
9350 in a shared library. */
9352 if (ptid_get_pid (inferior_ptid
) == 0)
9353 error (_("Unable to insert catchpoint. Try to start the program first."));
9355 /* At this point, we know that we are debugging an Ada program and
9356 that the inferior has been started, but we still are not able to
9357 find the run-time symbols. That can mean that we are in
9358 configurable run time mode, or that a-except as been optimized
9359 out by the linker... In any case, at this point it is not worth
9360 supporting this feature. */
9362 error (_("Cannot insert catchpoints in this configuration."));
9365 /* An observer of "executable_changed" events.
9366 Its role is to clear certain cached values that need to be recomputed
9367 each time a new executable is loaded by GDB. */
9370 ada_executable_changed_observer (void *unused
)
9372 /* If the executable changed, then it is possible that the Ada runtime
9373 is different. So we need to invalidate the exception support info
9375 exception_info
= NULL
;
9378 /* Return the name of the function at PC, NULL if could not find it.
9379 This function only checks the debugging information, not the symbol
9383 function_name_from_pc (CORE_ADDR pc
)
9387 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
9393 /* True iff FRAME is very likely to be that of a function that is
9394 part of the runtime system. This is all very heuristic, but is
9395 intended to be used as advice as to what frames are uninteresting
9399 is_known_support_routine (struct frame_info
*frame
)
9401 struct symtab_and_line sal
;
9405 /* If this code does not have any debugging information (no symtab),
9406 This cannot be any user code. */
9408 find_frame_sal (frame
, &sal
);
9409 if (sal
.symtab
== NULL
)
9412 /* If there is a symtab, but the associated source file cannot be
9413 located, then assume this is not user code: Selecting a frame
9414 for which we cannot display the code would not be very helpful
9415 for the user. This should also take care of case such as VxWorks
9416 where the kernel has some debugging info provided for a few units. */
9418 if (symtab_to_fullname (sal
.symtab
) == NULL
)
9421 /* Check the unit filename againt the Ada runtime file naming.
9422 We also check the name of the objfile against the name of some
9423 known system libraries that sometimes come with debugging info
9426 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
9428 re_comp (known_runtime_file_name_patterns
[i
]);
9429 if (re_exec (sal
.symtab
->filename
))
9431 if (sal
.symtab
->objfile
!= NULL
9432 && re_exec (sal
.symtab
->objfile
->name
))
9436 /* Check whether the function is a GNAT-generated entity. */
9438 func_name
= function_name_from_pc (get_frame_address_in_block (frame
));
9439 if (func_name
== NULL
)
9442 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
9444 re_comp (known_auxiliary_function_name_patterns
[i
]);
9445 if (re_exec (func_name
))
9452 /* Find the first frame that contains debugging information and that is not
9453 part of the Ada run-time, starting from FI and moving upward. */
9456 ada_find_printable_frame (struct frame_info
*fi
)
9458 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
9460 if (!is_known_support_routine (fi
))
9469 /* Assuming that the inferior just triggered an unhandled exception
9470 catchpoint, return the address in inferior memory where the name
9471 of the exception is stored.
9473 Return zero if the address could not be computed. */
9476 ada_unhandled_exception_name_addr (void)
9478 return parse_and_eval_address ("e.full_name");
9481 /* Same as ada_unhandled_exception_name_addr, except that this function
9482 should be used when the inferior uses an older version of the runtime,
9483 where the exception name needs to be extracted from a specific frame
9484 several frames up in the callstack. */
9487 ada_unhandled_exception_name_addr_from_raise (void)
9490 struct frame_info
*fi
;
9492 /* To determine the name of this exception, we need to select
9493 the frame corresponding to RAISE_SYM_NAME. This frame is
9494 at least 3 levels up, so we simply skip the first 3 frames
9495 without checking the name of their associated function. */
9496 fi
= get_current_frame ();
9497 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
9499 fi
= get_prev_frame (fi
);
9503 const char *func_name
=
9504 function_name_from_pc (get_frame_address_in_block (fi
));
9505 if (func_name
!= NULL
9506 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
9507 break; /* We found the frame we were looking for... */
9508 fi
= get_prev_frame (fi
);
9515 return parse_and_eval_address ("id.full_name");
9518 /* Assuming the inferior just triggered an Ada exception catchpoint
9519 (of any type), return the address in inferior memory where the name
9520 of the exception is stored, if applicable.
9522 Return zero if the address could not be computed, or if not relevant. */
9525 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
9526 struct breakpoint
*b
)
9530 case ex_catch_exception
:
9531 return (parse_and_eval_address ("e.full_name"));
9534 case ex_catch_exception_unhandled
:
9535 return exception_info
->unhandled_exception_name_addr ();
9538 case ex_catch_assert
:
9539 return 0; /* Exception name is not relevant in this case. */
9543 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9547 return 0; /* Should never be reached. */
9550 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
9551 any error that ada_exception_name_addr_1 might cause to be thrown.
9552 When an error is intercepted, a warning with the error message is printed,
9553 and zero is returned. */
9556 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
9557 struct breakpoint
*b
)
9559 struct gdb_exception e
;
9560 CORE_ADDR result
= 0;
9562 TRY_CATCH (e
, RETURN_MASK_ERROR
)
9564 result
= ada_exception_name_addr_1 (ex
, b
);
9569 warning (_("failed to get exception name: %s"), e
.message
);
9576 /* Implement the PRINT_IT method in the breakpoint_ops structure
9577 for all exception catchpoint kinds. */
9579 static enum print_stop_action
9580 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
9582 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
9583 char exception_name
[256];
9587 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
9588 exception_name
[sizeof (exception_name
) - 1] = '\0';
9591 ada_find_printable_frame (get_current_frame ());
9593 annotate_catchpoint (b
->number
);
9596 case ex_catch_exception
:
9598 printf_filtered (_("\nCatchpoint %d, %s at "),
9599 b
->number
, exception_name
);
9601 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
9603 case ex_catch_exception_unhandled
:
9605 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
9606 b
->number
, exception_name
);
9608 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
9611 case ex_catch_assert
:
9612 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
9617 return PRINT_SRC_AND_LOC
;
9620 /* Implement the PRINT_ONE method in the breakpoint_ops structure
9621 for all exception catchpoint kinds. */
9624 print_one_exception (enum exception_catchpoint_kind ex
,
9625 struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9630 ui_out_field_core_addr (uiout
, "addr", b
->loc
->address
);
9634 *last_addr
= b
->loc
->address
;
9637 case ex_catch_exception
:
9638 if (b
->exp_string
!= NULL
)
9640 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
9642 ui_out_field_string (uiout
, "what", msg
);
9646 ui_out_field_string (uiout
, "what", "all Ada exceptions");
9650 case ex_catch_exception_unhandled
:
9651 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
9654 case ex_catch_assert
:
9655 ui_out_field_string (uiout
, "what", "failed Ada assertions");
9659 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9664 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
9665 for all exception catchpoint kinds. */
9668 print_mention_exception (enum exception_catchpoint_kind ex
,
9669 struct breakpoint
*b
)
9673 case ex_catch_exception
:
9674 if (b
->exp_string
!= NULL
)
9675 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
9676 b
->number
, b
->exp_string
);
9678 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
9682 case ex_catch_exception_unhandled
:
9683 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
9687 case ex_catch_assert
:
9688 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
9692 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9697 /* Virtual table for "catch exception" breakpoints. */
9699 static enum print_stop_action
9700 print_it_catch_exception (struct breakpoint
*b
)
9702 return print_it_exception (ex_catch_exception
, b
);
9706 print_one_catch_exception (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9708 print_one_exception (ex_catch_exception
, b
, last_addr
);
9712 print_mention_catch_exception (struct breakpoint
*b
)
9714 print_mention_exception (ex_catch_exception
, b
);
9717 static struct breakpoint_ops catch_exception_breakpoint_ops
=
9719 print_it_catch_exception
,
9720 print_one_catch_exception
,
9721 print_mention_catch_exception
9724 /* Virtual table for "catch exception unhandled" breakpoints. */
9726 static enum print_stop_action
9727 print_it_catch_exception_unhandled (struct breakpoint
*b
)
9729 return print_it_exception (ex_catch_exception_unhandled
, b
);
9733 print_one_catch_exception_unhandled (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9735 print_one_exception (ex_catch_exception_unhandled
, b
, last_addr
);
9739 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
9741 print_mention_exception (ex_catch_exception_unhandled
, b
);
9744 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
9745 print_it_catch_exception_unhandled
,
9746 print_one_catch_exception_unhandled
,
9747 print_mention_catch_exception_unhandled
9750 /* Virtual table for "catch assert" breakpoints. */
9752 static enum print_stop_action
9753 print_it_catch_assert (struct breakpoint
*b
)
9755 return print_it_exception (ex_catch_assert
, b
);
9759 print_one_catch_assert (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
9761 print_one_exception (ex_catch_assert
, b
, last_addr
);
9765 print_mention_catch_assert (struct breakpoint
*b
)
9767 print_mention_exception (ex_catch_assert
, b
);
9770 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
9771 print_it_catch_assert
,
9772 print_one_catch_assert
,
9773 print_mention_catch_assert
9776 /* Return non-zero if B is an Ada exception catchpoint. */
9779 ada_exception_catchpoint_p (struct breakpoint
*b
)
9781 return (b
->ops
== &catch_exception_breakpoint_ops
9782 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
9783 || b
->ops
== &catch_assert_breakpoint_ops
);
9786 /* Return a newly allocated copy of the first space-separated token
9787 in ARGSP, and then adjust ARGSP to point immediately after that
9790 Return NULL if ARGPS does not contain any more tokens. */
9793 ada_get_next_arg (char **argsp
)
9795 char *args
= *argsp
;
9799 /* Skip any leading white space. */
9801 while (isspace (*args
))
9804 if (args
[0] == '\0')
9805 return NULL
; /* No more arguments. */
9807 /* Find the end of the current argument. */
9810 while (*end
!= '\0' && !isspace (*end
))
9813 /* Adjust ARGSP to point to the start of the next argument. */
9817 /* Make a copy of the current argument and return it. */
9819 result
= xmalloc (end
- args
+ 1);
9820 strncpy (result
, args
, end
- args
);
9821 result
[end
- args
] = '\0';
9826 /* Split the arguments specified in a "catch exception" command.
9827 Set EX to the appropriate catchpoint type.
9828 Set EXP_STRING to the name of the specific exception if
9829 specified by the user. */
9832 catch_ada_exception_command_split (char *args
,
9833 enum exception_catchpoint_kind
*ex
,
9836 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
9837 char *exception_name
;
9839 exception_name
= ada_get_next_arg (&args
);
9840 make_cleanup (xfree
, exception_name
);
9842 /* Check that we do not have any more arguments. Anything else
9845 while (isspace (*args
))
9848 if (args
[0] != '\0')
9849 error (_("Junk at end of expression"));
9851 discard_cleanups (old_chain
);
9853 if (exception_name
== NULL
)
9855 /* Catch all exceptions. */
9856 *ex
= ex_catch_exception
;
9859 else if (strcmp (exception_name
, "unhandled") == 0)
9861 /* Catch unhandled exceptions. */
9862 *ex
= ex_catch_exception_unhandled
;
9867 /* Catch a specific exception. */
9868 *ex
= ex_catch_exception
;
9869 *exp_string
= exception_name
;
9873 /* Return the name of the symbol on which we should break in order to
9874 implement a catchpoint of the EX kind. */
9877 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
9879 gdb_assert (exception_info
!= NULL
);
9883 case ex_catch_exception
:
9884 return (exception_info
->catch_exception_sym
);
9886 case ex_catch_exception_unhandled
:
9887 return (exception_info
->catch_exception_unhandled_sym
);
9889 case ex_catch_assert
:
9890 return (exception_info
->catch_assert_sym
);
9893 internal_error (__FILE__
, __LINE__
,
9894 _("unexpected catchpoint kind (%d)"), ex
);
9898 /* Return the breakpoint ops "virtual table" used for catchpoints
9901 static struct breakpoint_ops
*
9902 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
9906 case ex_catch_exception
:
9907 return (&catch_exception_breakpoint_ops
);
9909 case ex_catch_exception_unhandled
:
9910 return (&catch_exception_unhandled_breakpoint_ops
);
9912 case ex_catch_assert
:
9913 return (&catch_assert_breakpoint_ops
);
9916 internal_error (__FILE__
, __LINE__
,
9917 _("unexpected catchpoint kind (%d)"), ex
);
9921 /* Return the condition that will be used to match the current exception
9922 being raised with the exception that the user wants to catch. This
9923 assumes that this condition is used when the inferior just triggered
9924 an exception catchpoint.
9926 The string returned is a newly allocated string that needs to be
9927 deallocated later. */
9930 ada_exception_catchpoint_cond_string (const char *exp_string
)
9932 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
9935 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
9937 static struct expression
*
9938 ada_parse_catchpoint_condition (char *cond_string
,
9939 struct symtab_and_line sal
)
9941 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
9944 /* Return the symtab_and_line that should be used to insert an exception
9945 catchpoint of the TYPE kind.
9947 EX_STRING should contain the name of a specific exception
9948 that the catchpoint should catch, or NULL otherwise.
9950 The idea behind all the remaining parameters is that their names match
9951 the name of certain fields in the breakpoint structure that are used to
9952 handle exception catchpoints. This function returns the value to which
9953 these fields should be set, depending on the type of catchpoint we need
9956 If COND and COND_STRING are both non-NULL, any value they might
9957 hold will be free'ed, and then replaced by newly allocated ones.
9958 These parameters are left untouched otherwise. */
9960 static struct symtab_and_line
9961 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
9962 char **addr_string
, char **cond_string
,
9963 struct expression
**cond
, struct breakpoint_ops
**ops
)
9965 const char *sym_name
;
9967 struct symtab_and_line sal
;
9969 /* First, find out which exception support info to use. */
9970 ada_exception_support_info_sniffer ();
9972 /* Then lookup the function on which we will break in order to catch
9973 the Ada exceptions requested by the user. */
9975 sym_name
= ada_exception_sym_name (ex
);
9976 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
9978 /* The symbol we're looking up is provided by a unit in the GNAT runtime
9979 that should be compiled with debugging information. As a result, we
9980 expect to find that symbol in the symtabs. If we don't find it, then
9981 the target most likely does not support Ada exceptions, or we cannot
9982 insert exception breakpoints yet, because the GNAT runtime hasn't been
9985 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
9986 in such a way that no debugging information is produced for the symbol
9987 we are looking for. In this case, we could search the minimal symbols
9988 as a fall-back mechanism. This would still be operating in degraded
9989 mode, however, as we would still be missing the debugging information
9990 that is needed in order to extract the name of the exception being
9991 raised (this name is printed in the catchpoint message, and is also
9992 used when trying to catch a specific exception). We do not handle
9993 this case for now. */
9996 error (_("Unable to break on '%s' in this configuration."), sym_name
);
9998 /* Make sure that the symbol we found corresponds to a function. */
9999 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
10000 error (_("Symbol \"%s\" is not a function (class = %d)"),
10001 sym_name
, SYMBOL_CLASS (sym
));
10003 sal
= find_function_start_sal (sym
, 1);
10005 /* Set ADDR_STRING. */
10007 *addr_string
= xstrdup (sym_name
);
10009 /* Set the COND and COND_STRING (if not NULL). */
10011 if (cond_string
!= NULL
&& cond
!= NULL
)
10013 if (*cond_string
!= NULL
)
10015 xfree (*cond_string
);
10016 *cond_string
= NULL
;
10023 if (exp_string
!= NULL
)
10025 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
10026 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
10031 *ops
= ada_exception_breakpoint_ops (ex
);
10036 /* Parse the arguments (ARGS) of the "catch exception" command.
10038 Set TYPE to the appropriate exception catchpoint type.
10039 If the user asked the catchpoint to catch only a specific
10040 exception, then save the exception name in ADDR_STRING.
10042 See ada_exception_sal for a description of all the remaining
10043 function arguments of this function. */
10045 struct symtab_and_line
10046 ada_decode_exception_location (char *args
, char **addr_string
,
10047 char **exp_string
, char **cond_string
,
10048 struct expression
**cond
,
10049 struct breakpoint_ops
**ops
)
10051 enum exception_catchpoint_kind ex
;
10053 catch_ada_exception_command_split (args
, &ex
, exp_string
);
10054 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
10058 struct symtab_and_line
10059 ada_decode_assert_location (char *args
, char **addr_string
,
10060 struct breakpoint_ops
**ops
)
10062 /* Check that no argument where provided at the end of the command. */
10066 while (isspace (*args
))
10069 error (_("Junk at end of arguments."));
10072 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
10077 /* Information about operators given special treatment in functions
10079 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10081 #define ADA_OPERATORS \
10082 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10083 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10084 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10085 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10086 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10087 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10088 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10089 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10090 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10091 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10092 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10093 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10094 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10095 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10096 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10097 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10098 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10099 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10100 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10103 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
10105 switch (exp
->elts
[pc
- 1].opcode
)
10108 operator_length_standard (exp
, pc
, oplenp
, argsp
);
10111 #define OP_DEFN(op, len, args, binop) \
10112 case op: *oplenp = len; *argsp = args; break;
10118 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
10123 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
10129 ada_op_name (enum exp_opcode opcode
)
10134 return op_name_standard (opcode
);
10136 #define OP_DEFN(op, len, args, binop) case op: return #op;
10141 return "OP_AGGREGATE";
10143 return "OP_CHOICES";
10149 /* As for operator_length, but assumes PC is pointing at the first
10150 element of the operator, and gives meaningful results only for the
10151 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10154 ada_forward_operator_length (struct expression
*exp
, int pc
,
10155 int *oplenp
, int *argsp
)
10157 switch (exp
->elts
[pc
].opcode
)
10160 *oplenp
= *argsp
= 0;
10163 #define OP_DEFN(op, len, args, binop) \
10164 case op: *oplenp = len; *argsp = args; break;
10170 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10175 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
10181 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10182 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
10190 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
10192 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
10197 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
10201 /* Ada attributes ('Foo). */
10204 case OP_ATR_LENGTH
:
10208 case OP_ATR_MODULUS
:
10215 case UNOP_IN_RANGE
:
10217 /* XXX: gdb_sprint_host_address, type_sprint */
10218 fprintf_filtered (stream
, _("Type @"));
10219 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
10220 fprintf_filtered (stream
, " (");
10221 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
10222 fprintf_filtered (stream
, ")");
10224 case BINOP_IN_BOUNDS
:
10225 fprintf_filtered (stream
, " (%d)",
10226 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
10228 case TERNOP_IN_RANGE
:
10233 case OP_DISCRETE_RANGE
:
10234 case OP_POSITIONAL
:
10241 char *name
= &exp
->elts
[elt
+ 2].string
;
10242 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
10243 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
10248 return dump_subexp_body_standard (exp
, stream
, elt
);
10252 for (i
= 0; i
< nargs
; i
+= 1)
10253 elt
= dump_subexp (exp
, stream
, elt
);
10258 /* The Ada extension of print_subexp (q.v.). */
10261 ada_print_subexp (struct expression
*exp
, int *pos
,
10262 struct ui_file
*stream
, enum precedence prec
)
10264 int oplen
, nargs
, i
;
10266 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
10268 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10275 print_subexp_standard (exp
, pos
, stream
, prec
);
10279 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
10282 case BINOP_IN_BOUNDS
:
10283 /* XXX: sprint_subexp */
10284 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10285 fputs_filtered (" in ", stream
);
10286 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10287 fputs_filtered ("'range", stream
);
10288 if (exp
->elts
[pc
+ 1].longconst
> 1)
10289 fprintf_filtered (stream
, "(%ld)",
10290 (long) exp
->elts
[pc
+ 1].longconst
);
10293 case TERNOP_IN_RANGE
:
10294 if (prec
>= PREC_EQUAL
)
10295 fputs_filtered ("(", stream
);
10296 /* XXX: sprint_subexp */
10297 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10298 fputs_filtered (" in ", stream
);
10299 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10300 fputs_filtered (" .. ", stream
);
10301 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10302 if (prec
>= PREC_EQUAL
)
10303 fputs_filtered (")", stream
);
10308 case OP_ATR_LENGTH
:
10312 case OP_ATR_MODULUS
:
10317 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10319 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10320 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10324 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10325 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10329 for (tem
= 1; tem
< nargs
; tem
+= 1)
10331 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10332 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10334 fputs_filtered (")", stream
);
10339 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10340 fputs_filtered ("'(", stream
);
10341 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10342 fputs_filtered (")", stream
);
10345 case UNOP_IN_RANGE
:
10346 /* XXX: sprint_subexp */
10347 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10348 fputs_filtered (" in ", stream
);
10349 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10352 case OP_DISCRETE_RANGE
:
10353 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10354 fputs_filtered ("..", stream
);
10355 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10359 fputs_filtered ("others => ", stream
);
10360 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10364 for (i
= 0; i
< nargs
-1; i
+= 1)
10367 fputs_filtered ("|", stream
);
10368 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10370 fputs_filtered (" => ", stream
);
10371 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10374 case OP_POSITIONAL
:
10375 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10379 fputs_filtered ("(", stream
);
10380 for (i
= 0; i
< nargs
; i
+= 1)
10383 fputs_filtered (", ", stream
);
10384 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10386 fputs_filtered (")", stream
);
10391 /* Table mapping opcodes into strings for printing operators
10392 and precedences of the operators. */
10394 static const struct op_print ada_op_print_tab
[] = {
10395 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10396 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10397 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10398 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10399 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10400 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10401 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10402 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10403 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10404 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10405 {">", BINOP_GTR
, PREC_ORDER
, 0},
10406 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10407 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10408 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10409 {"+", BINOP_ADD
, PREC_ADD
, 0},
10410 {"-", BINOP_SUB
, PREC_ADD
, 0},
10411 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10412 {"*", BINOP_MUL
, PREC_MUL
, 0},
10413 {"/", BINOP_DIV
, PREC_MUL
, 0},
10414 {"rem", BINOP_REM
, PREC_MUL
, 0},
10415 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10416 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10417 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10418 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10419 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10420 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10421 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10422 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10423 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10424 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10425 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10429 enum ada_primitive_types
{
10430 ada_primitive_type_int
,
10431 ada_primitive_type_long
,
10432 ada_primitive_type_short
,
10433 ada_primitive_type_char
,
10434 ada_primitive_type_float
,
10435 ada_primitive_type_double
,
10436 ada_primitive_type_void
,
10437 ada_primitive_type_long_long
,
10438 ada_primitive_type_long_double
,
10439 ada_primitive_type_natural
,
10440 ada_primitive_type_positive
,
10441 ada_primitive_type_system_address
,
10442 nr_ada_primitive_types
10446 ada_language_arch_info (struct gdbarch
*gdbarch
,
10447 struct language_arch_info
*lai
)
10449 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
10450 lai
->primitive_type_vector
10451 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
10453 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10454 init_type (TYPE_CODE_INT
,
10455 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10456 0, "integer", (struct objfile
*) NULL
);
10457 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10458 init_type (TYPE_CODE_INT
,
10459 gdbarch_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10460 0, "long_integer", (struct objfile
*) NULL
);
10461 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10462 init_type (TYPE_CODE_INT
,
10463 gdbarch_short_bit (gdbarch
) / TARGET_CHAR_BIT
,
10464 0, "short_integer", (struct objfile
*) NULL
);
10465 lai
->string_char_type
=
10466 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10467 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10468 0, "character", (struct objfile
*) NULL
);
10469 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10470 init_type (TYPE_CODE_FLT
,
10471 gdbarch_float_bit (gdbarch
)/ TARGET_CHAR_BIT
,
10472 0, "float", (struct objfile
*) NULL
);
10473 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10474 init_type (TYPE_CODE_FLT
,
10475 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10476 0, "long_float", (struct objfile
*) NULL
);
10477 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10478 init_type (TYPE_CODE_INT
,
10479 gdbarch_long_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10480 0, "long_long_integer", (struct objfile
*) NULL
);
10481 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10482 init_type (TYPE_CODE_FLT
,
10483 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10484 0, "long_long_float", (struct objfile
*) NULL
);
10485 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10486 init_type (TYPE_CODE_INT
,
10487 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10488 0, "natural", (struct objfile
*) NULL
);
10489 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10490 init_type (TYPE_CODE_INT
,
10491 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10492 0, "positive", (struct objfile
*) NULL
);
10493 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10495 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10496 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10497 (struct objfile
*) NULL
));
10498 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
10499 = "system__address";
10502 /* Language vector */
10504 /* Not really used, but needed in the ada_language_defn. */
10507 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10509 ada_emit_char (c
, stream
, quoter
, 1);
10515 warnings_issued
= 0;
10516 return ada_parse ();
10519 static const struct exp_descriptor ada_exp_descriptor
= {
10521 ada_operator_length
,
10523 ada_dump_subexp_body
,
10524 ada_evaluate_subexp
10527 const struct language_defn ada_language_defn
= {
10528 "ada", /* Language name */
10532 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
10533 that's not quite what this means. */
10535 &ada_exp_descriptor
,
10539 ada_printchar
, /* Print a character constant */
10540 ada_printstr
, /* Function to print string constant */
10541 emit_char
, /* Function to print single char (not used) */
10542 ada_print_type
, /* Print a type using appropriate syntax */
10543 ada_val_print
, /* Print a value using appropriate syntax */
10544 ada_value_print
, /* Print a top-level value */
10545 NULL
, /* Language specific skip_trampoline */
10546 NULL
, /* value_of_this */
10547 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
10548 basic_lookup_transparent_type
, /* lookup_transparent_type */
10549 ada_la_decode
, /* Language specific symbol demangler */
10550 NULL
, /* Language specific class_name_from_physname */
10551 ada_op_print_tab
, /* expression operators for printing */
10552 0, /* c-style arrays */
10553 1, /* String lower bound */
10554 ada_get_gdb_completer_word_break_characters
,
10555 ada_language_arch_info
,
10556 ada_print_array_index
,
10557 default_pass_by_reference
,
10562 _initialize_ada_language (void)
10564 add_language (&ada_language_defn
);
10566 varsize_limit
= 65536;
10568 obstack_init (&symbol_list_obstack
);
10570 decoded_names_store
= htab_create_alloc
10571 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
10572 NULL
, xcalloc
, xfree
);
10574 observer_attach_executable_changed (ada_executable_changed_observer
);