]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Return std::string from ada_exception_catchpoint_cond_string
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
e2882c85 3 Copyright (C) 1992-2018 Free Software Foundation, Inc.
14f9c5c9 4
a9762ec7 5 This file is part of GDB.
14f9c5c9 6
a9762ec7
JB
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
14f9c5c9 11
a9762ec7
JB
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
14f9c5c9 16
a9762ec7
JB
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 19
96d887e8 20
4c4b4cd2 21#include "defs.h"
14f9c5c9 22#include <ctype.h>
14f9c5c9 23#include "demangle.h"
4c4b4cd2
PH
24#include "gdb_regex.h"
25#include "frame.h"
14f9c5c9
AS
26#include "symtab.h"
27#include "gdbtypes.h"
28#include "gdbcmd.h"
29#include "expression.h"
30#include "parser-defs.h"
31#include "language.h"
a53b64ea 32#include "varobj.h"
14f9c5c9
AS
33#include "c-lang.h"
34#include "inferior.h"
35#include "symfile.h"
36#include "objfiles.h"
37#include "breakpoint.h"
38#include "gdbcore.h"
4c4b4cd2
PH
39#include "hashtab.h"
40#include "gdb_obstack.h"
14f9c5c9 41#include "ada-lang.h"
4c4b4cd2 42#include "completer.h"
53ce3c39 43#include <sys/stat.h>
14f9c5c9 44#include "ui-out.h"
fe898f56 45#include "block.h"
04714b91 46#include "infcall.h"
de4f826b 47#include "dictionary.h"
f7f9143b
JB
48#include "annotate.h"
49#include "valprint.h"
9bbc9174 50#include "source.h"
76727919 51#include "observable.h"
2ba95b9b 52#include "vec.h"
692465f1 53#include "stack.h"
fa864999 54#include "gdb_vecs.h"
79d43c61 55#include "typeprint.h"
22cee43f 56#include "namespace.h"
14f9c5c9 57
ccefe4c4 58#include "psymtab.h"
40bc484c 59#include "value.h"
956a9fb9 60#include "mi/mi-common.h"
9ac4176b 61#include "arch-utils.h"
0fcd72ba 62#include "cli/cli-utils.h"
14bc53a8 63#include "common/function-view.h"
d5722aa2 64#include "common/byte-vector.h"
ab816a27 65#include <algorithm>
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40bc484c 107static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 108
4c4b4cd2 109static void ada_add_block_symbols (struct obstack *,
b5ec771e
PA
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
14f9c5c9 113
22cee43f 114static void ada_add_all_symbols (struct obstack *, const struct block *,
b5ec771e
PA
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
22cee43f 117
d12307c1 118static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 119
76a01679 120static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 121 const struct block *);
14f9c5c9 122
4c4b4cd2
PH
123static int num_defns_collected (struct obstack *);
124
d12307c1 125static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 126
e9d9f57e 127static struct value *resolve_subexp (expression_up *, int *, int,
76a01679 128 struct type *);
14f9c5c9 129
e9d9f57e 130static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 131 struct symbol *, const struct block *);
14f9c5c9 132
d2e4a39e 133static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 134
a121b7c1 135static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
136
137static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 138
d2e4a39e 139static int numeric_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int integer_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int scalar_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int discrete_type_p (struct type *);
14f9c5c9 146
aeb5907d
JB
147static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 153 const struct block *);
aeb5907d 154
a121b7c1 155static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 156 int, int);
4c4b4cd2 157
d2e4a39e 158static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 159
b4ba55a1
JB
160static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
d2e4a39e 163static int is_dynamic_field (struct type *, int);
14f9c5c9 164
10a2c479 165static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 166 const gdb_byte *,
4c4b4cd2
PH
167 CORE_ADDR, struct value *);
168
169static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 170
28c85d6c 171static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 172
d2e4a39e 173static struct type *to_static_fixed_type (struct type *);
f192137b 174static struct type *static_unwrap_type (struct type *type);
14f9c5c9 175
d2e4a39e 176static struct value *unwrap_value (struct value *);
14f9c5c9 177
ad82864c 178static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 179
ad82864c 180static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 181
ad82864c
JB
182static long decode_packed_array_bitsize (struct type *);
183
184static struct value *decode_constrained_packed_array (struct value *);
185
186static int ada_is_packed_array_type (struct type *);
187
188static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 189
d2e4a39e 190static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 191 struct value **);
14f9c5c9 192
50810684 193static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 194
4c4b4cd2
PH
195static struct value *coerce_unspec_val_to_type (struct value *,
196 struct type *);
14f9c5c9 197
d2e4a39e 198static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 199
d2e4a39e 200static int equiv_types (struct type *, struct type *);
14f9c5c9 201
d2e4a39e 202static int is_name_suffix (const char *);
14f9c5c9 203
73589123
PH
204static int advance_wild_match (const char **, const char *, int);
205
b5ec771e 206static bool wild_match (const char *name, const char *patn);
14f9c5c9 207
d2e4a39e 208static struct value *ada_coerce_ref (struct value *);
14f9c5c9 209
4c4b4cd2
PH
210static LONGEST pos_atr (struct value *);
211
3cb382c9 212static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 213
d2e4a39e 214static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 215
4c4b4cd2
PH
216static struct symbol *standard_lookup (const char *, const struct block *,
217 domain_enum);
14f9c5c9 218
108d56a4 219static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
220 struct type *);
221
222static struct value *ada_value_primitive_field (struct value *, int, int,
223 struct type *);
224
0d5cff50 225static int find_struct_field (const char *, struct type *, int,
52ce6436 226 struct type **, int *, int *, int *, int *);
4c4b4cd2 227
d12307c1 228static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
229 struct value **, int, const char *,
230 struct type *);
231
4c4b4cd2
PH
232static int ada_is_direct_array_type (struct type *);
233
72d5681a
PH
234static void ada_language_arch_info (struct gdbarch *,
235 struct language_arch_info *);
714e53ab 236
52ce6436
PH
237static struct value *ada_index_struct_field (int, struct value *, int,
238 struct type *);
239
240static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
241 struct expression *,
242 int *, enum noside);
52ce6436
PH
243
244static void aggregate_assign_from_choices (struct value *, struct value *,
245 struct expression *,
246 int *, LONGEST *, int *,
247 int, LONGEST, LONGEST);
248
249static void aggregate_assign_positional (struct value *, struct value *,
250 struct expression *,
251 int *, LONGEST *, int *, int,
252 LONGEST, LONGEST);
253
254
255static void aggregate_assign_others (struct value *, struct value *,
256 struct expression *,
257 int *, LONGEST *, int, LONGEST, LONGEST);
258
259
260static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
261
262
263static struct value *ada_evaluate_subexp (struct type *, struct expression *,
264 int *, enum noside);
265
266static void ada_forward_operator_length (struct expression *, int, int *,
267 int *);
852dff6c
JB
268
269static struct type *ada_find_any_type (const char *name);
b5ec771e
PA
270
271static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
272 (const lookup_name_info &lookup_name);
273
4c4b4cd2
PH
274\f
275
ee01b665
JB
276/* The result of a symbol lookup to be stored in our symbol cache. */
277
278struct cache_entry
279{
280 /* The name used to perform the lookup. */
281 const char *name;
282 /* The namespace used during the lookup. */
fe978cb0 283 domain_enum domain;
ee01b665
JB
284 /* The symbol returned by the lookup, or NULL if no matching symbol
285 was found. */
286 struct symbol *sym;
287 /* The block where the symbol was found, or NULL if no matching
288 symbol was found. */
289 const struct block *block;
290 /* A pointer to the next entry with the same hash. */
291 struct cache_entry *next;
292};
293
294/* The Ada symbol cache, used to store the result of Ada-mode symbol
295 lookups in the course of executing the user's commands.
296
297 The cache is implemented using a simple, fixed-sized hash.
298 The size is fixed on the grounds that there are not likely to be
299 all that many symbols looked up during any given session, regardless
300 of the size of the symbol table. If we decide to go to a resizable
301 table, let's just use the stuff from libiberty instead. */
302
303#define HASH_SIZE 1009
304
305struct ada_symbol_cache
306{
307 /* An obstack used to store the entries in our cache. */
308 struct obstack cache_space;
309
310 /* The root of the hash table used to implement our symbol cache. */
311 struct cache_entry *root[HASH_SIZE];
312};
313
314static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 315
4c4b4cd2 316/* Maximum-sized dynamic type. */
14f9c5c9
AS
317static unsigned int varsize_limit;
318
67cb5b2d 319static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
320#ifdef VMS
321 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
322#else
14f9c5c9 323 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 324#endif
14f9c5c9 325
4c4b4cd2 326/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 327static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 328 = "__gnat_ada_main_program_name";
14f9c5c9 329
4c4b4cd2
PH
330/* Limit on the number of warnings to raise per expression evaluation. */
331static int warning_limit = 2;
332
333/* Number of warning messages issued; reset to 0 by cleanups after
334 expression evaluation. */
335static int warnings_issued = 0;
336
337static const char *known_runtime_file_name_patterns[] = {
338 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
339};
340
341static const char *known_auxiliary_function_name_patterns[] = {
342 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
343};
344
c6044dd1
JB
345/* Maintenance-related settings for this module. */
346
347static struct cmd_list_element *maint_set_ada_cmdlist;
348static struct cmd_list_element *maint_show_ada_cmdlist;
349
350/* Implement the "maintenance set ada" (prefix) command. */
351
352static void
981a3fb3 353maint_set_ada_cmd (const char *args, int from_tty)
c6044dd1 354{
635c7e8a
TT
355 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
356 gdb_stdout);
c6044dd1
JB
357}
358
359/* Implement the "maintenance show ada" (prefix) command. */
360
361static void
981a3fb3 362maint_show_ada_cmd (const char *args, int from_tty)
c6044dd1
JB
363{
364 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
365}
366
367/* The "maintenance ada set/show ignore-descriptive-type" value. */
368
369static int ada_ignore_descriptive_types_p = 0;
370
e802dbe0
JB
371 /* Inferior-specific data. */
372
373/* Per-inferior data for this module. */
374
375struct ada_inferior_data
376{
377 /* The ada__tags__type_specific_data type, which is used when decoding
378 tagged types. With older versions of GNAT, this type was directly
379 accessible through a component ("tsd") in the object tag. But this
380 is no longer the case, so we cache it for each inferior. */
381 struct type *tsd_type;
3eecfa55
JB
382
383 /* The exception_support_info data. This data is used to determine
384 how to implement support for Ada exception catchpoints in a given
385 inferior. */
386 const struct exception_support_info *exception_info;
e802dbe0
JB
387};
388
389/* Our key to this module's inferior data. */
390static const struct inferior_data *ada_inferior_data;
391
392/* A cleanup routine for our inferior data. */
393static void
394ada_inferior_data_cleanup (struct inferior *inf, void *arg)
395{
396 struct ada_inferior_data *data;
397
9a3c8263 398 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
399 if (data != NULL)
400 xfree (data);
401}
402
403/* Return our inferior data for the given inferior (INF).
404
405 This function always returns a valid pointer to an allocated
406 ada_inferior_data structure. If INF's inferior data has not
407 been previously set, this functions creates a new one with all
408 fields set to zero, sets INF's inferior to it, and then returns
409 a pointer to that newly allocated ada_inferior_data. */
410
411static struct ada_inferior_data *
412get_ada_inferior_data (struct inferior *inf)
413{
414 struct ada_inferior_data *data;
415
9a3c8263 416 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
417 if (data == NULL)
418 {
41bf6aca 419 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
420 set_inferior_data (inf, ada_inferior_data, data);
421 }
422
423 return data;
424}
425
426/* Perform all necessary cleanups regarding our module's inferior data
427 that is required after the inferior INF just exited. */
428
429static void
430ada_inferior_exit (struct inferior *inf)
431{
432 ada_inferior_data_cleanup (inf, NULL);
433 set_inferior_data (inf, ada_inferior_data, NULL);
434}
435
ee01b665
JB
436
437 /* program-space-specific data. */
438
439/* This module's per-program-space data. */
440struct ada_pspace_data
441{
442 /* The Ada symbol cache. */
443 struct ada_symbol_cache *sym_cache;
444};
445
446/* Key to our per-program-space data. */
447static const struct program_space_data *ada_pspace_data_handle;
448
449/* Return this module's data for the given program space (PSPACE).
450 If not is found, add a zero'ed one now.
451
452 This function always returns a valid object. */
453
454static struct ada_pspace_data *
455get_ada_pspace_data (struct program_space *pspace)
456{
457 struct ada_pspace_data *data;
458
9a3c8263
SM
459 data = ((struct ada_pspace_data *)
460 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
461 if (data == NULL)
462 {
463 data = XCNEW (struct ada_pspace_data);
464 set_program_space_data (pspace, ada_pspace_data_handle, data);
465 }
466
467 return data;
468}
469
470/* The cleanup callback for this module's per-program-space data. */
471
472static void
473ada_pspace_data_cleanup (struct program_space *pspace, void *data)
474{
9a3c8263 475 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
476
477 if (pspace_data->sym_cache != NULL)
478 ada_free_symbol_cache (pspace_data->sym_cache);
479 xfree (pspace_data);
480}
481
4c4b4cd2
PH
482 /* Utilities */
483
720d1a40 484/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 485 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
486
487 Normally, we really expect a typedef type to only have 1 typedef layer.
488 In other words, we really expect the target type of a typedef type to be
489 a non-typedef type. This is particularly true for Ada units, because
490 the language does not have a typedef vs not-typedef distinction.
491 In that respect, the Ada compiler has been trying to eliminate as many
492 typedef definitions in the debugging information, since they generally
493 do not bring any extra information (we still use typedef under certain
494 circumstances related mostly to the GNAT encoding).
495
496 Unfortunately, we have seen situations where the debugging information
497 generated by the compiler leads to such multiple typedef layers. For
498 instance, consider the following example with stabs:
499
500 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
501 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
502
503 This is an error in the debugging information which causes type
504 pck__float_array___XUP to be defined twice, and the second time,
505 it is defined as a typedef of a typedef.
506
507 This is on the fringe of legality as far as debugging information is
508 concerned, and certainly unexpected. But it is easy to handle these
509 situations correctly, so we can afford to be lenient in this case. */
510
511static struct type *
512ada_typedef_target_type (struct type *type)
513{
514 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
515 type = TYPE_TARGET_TYPE (type);
516 return type;
517}
518
41d27058
JB
519/* Given DECODED_NAME a string holding a symbol name in its
520 decoded form (ie using the Ada dotted notation), returns
521 its unqualified name. */
522
523static const char *
524ada_unqualified_name (const char *decoded_name)
525{
2b0f535a
JB
526 const char *result;
527
528 /* If the decoded name starts with '<', it means that the encoded
529 name does not follow standard naming conventions, and thus that
530 it is not your typical Ada symbol name. Trying to unqualify it
531 is therefore pointless and possibly erroneous. */
532 if (decoded_name[0] == '<')
533 return decoded_name;
534
535 result = strrchr (decoded_name, '.');
41d27058
JB
536 if (result != NULL)
537 result++; /* Skip the dot... */
538 else
539 result = decoded_name;
540
541 return result;
542}
543
544/* Return a string starting with '<', followed by STR, and '>'.
545 The result is good until the next call. */
546
547static char *
548add_angle_brackets (const char *str)
549{
550 static char *result = NULL;
551
552 xfree (result);
88c15c34 553 result = xstrprintf ("<%s>", str);
41d27058
JB
554 return result;
555}
96d887e8 556
67cb5b2d 557static const char *
4c4b4cd2
PH
558ada_get_gdb_completer_word_break_characters (void)
559{
560 return ada_completer_word_break_characters;
561}
562
e79af960
JB
563/* Print an array element index using the Ada syntax. */
564
565static void
566ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 567 const struct value_print_options *options)
e79af960 568{
79a45b7d 569 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
570 fprintf_filtered (stream, " => ");
571}
572
f27cf670 573/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 574 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 575 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 576
f27cf670
AS
577void *
578grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 579{
d2e4a39e
AS
580 if (*size < min_size)
581 {
582 *size *= 2;
583 if (*size < min_size)
4c4b4cd2 584 *size = min_size;
f27cf670 585 vect = xrealloc (vect, *size * element_size);
d2e4a39e 586 }
f27cf670 587 return vect;
14f9c5c9
AS
588}
589
590/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 591 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
592
593static int
ebf56fd3 594field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
595{
596 int len = strlen (target);
5b4ee69b 597
d2e4a39e 598 return
4c4b4cd2
PH
599 (strncmp (field_name, target, len) == 0
600 && (field_name[len] == '\0'
61012eef 601 || (startswith (field_name + len, "___")
76a01679
JB
602 && strcmp (field_name + strlen (field_name) - 6,
603 "___XVN") != 0)));
14f9c5c9
AS
604}
605
606
872c8b51
JB
607/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
608 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
609 and return its index. This function also handles fields whose name
610 have ___ suffixes because the compiler sometimes alters their name
611 by adding such a suffix to represent fields with certain constraints.
612 If the field could not be found, return a negative number if
613 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
614
615int
616ada_get_field_index (const struct type *type, const char *field_name,
617 int maybe_missing)
618{
619 int fieldno;
872c8b51
JB
620 struct type *struct_type = check_typedef ((struct type *) type);
621
622 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
623 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
624 return fieldno;
625
626 if (!maybe_missing)
323e0a4a 627 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 628 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
629
630 return -1;
631}
632
633/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
634
635int
d2e4a39e 636ada_name_prefix_len (const char *name)
14f9c5c9
AS
637{
638 if (name == NULL)
639 return 0;
d2e4a39e 640 else
14f9c5c9 641 {
d2e4a39e 642 const char *p = strstr (name, "___");
5b4ee69b 643
14f9c5c9 644 if (p == NULL)
4c4b4cd2 645 return strlen (name);
14f9c5c9 646 else
4c4b4cd2 647 return p - name;
14f9c5c9
AS
648 }
649}
650
4c4b4cd2
PH
651/* Return non-zero if SUFFIX is a suffix of STR.
652 Return zero if STR is null. */
653
14f9c5c9 654static int
d2e4a39e 655is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
656{
657 int len1, len2;
5b4ee69b 658
14f9c5c9
AS
659 if (str == NULL)
660 return 0;
661 len1 = strlen (str);
662 len2 = strlen (suffix);
4c4b4cd2 663 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
664}
665
4c4b4cd2
PH
666/* The contents of value VAL, treated as a value of type TYPE. The
667 result is an lval in memory if VAL is. */
14f9c5c9 668
d2e4a39e 669static struct value *
4c4b4cd2 670coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 671{
61ee279c 672 type = ada_check_typedef (type);
df407dfe 673 if (value_type (val) == type)
4c4b4cd2 674 return val;
d2e4a39e 675 else
14f9c5c9 676 {
4c4b4cd2
PH
677 struct value *result;
678
679 /* Make sure that the object size is not unreasonable before
680 trying to allocate some memory for it. */
c1b5a1a6 681 ada_ensure_varsize_limit (type);
4c4b4cd2 682
41e8491f
JK
683 if (value_lazy (val)
684 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
685 result = allocate_value_lazy (type);
686 else
687 {
688 result = allocate_value (type);
9a0dc9e3 689 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 690 }
74bcbdf3 691 set_value_component_location (result, val);
9bbda503
AC
692 set_value_bitsize (result, value_bitsize (val));
693 set_value_bitpos (result, value_bitpos (val));
42ae5230 694 set_value_address (result, value_address (val));
14f9c5c9
AS
695 return result;
696 }
697}
698
fc1a4b47
AC
699static const gdb_byte *
700cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
701{
702 if (valaddr == NULL)
703 return NULL;
704 else
705 return valaddr + offset;
706}
707
708static CORE_ADDR
ebf56fd3 709cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
710{
711 if (address == 0)
712 return 0;
d2e4a39e 713 else
14f9c5c9
AS
714 return address + offset;
715}
716
4c4b4cd2
PH
717/* Issue a warning (as for the definition of warning in utils.c, but
718 with exactly one argument rather than ...), unless the limit on the
719 number of warnings has passed during the evaluation of the current
720 expression. */
a2249542 721
77109804
AC
722/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
723 provided by "complaint". */
a0b31db1 724static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 725
14f9c5c9 726static void
a2249542 727lim_warning (const char *format, ...)
14f9c5c9 728{
a2249542 729 va_list args;
a2249542 730
5b4ee69b 731 va_start (args, format);
4c4b4cd2
PH
732 warnings_issued += 1;
733 if (warnings_issued <= warning_limit)
a2249542
MK
734 vwarning (format, args);
735
736 va_end (args);
4c4b4cd2
PH
737}
738
714e53ab
PH
739/* Issue an error if the size of an object of type T is unreasonable,
740 i.e. if it would be a bad idea to allocate a value of this type in
741 GDB. */
742
c1b5a1a6
JB
743void
744ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
745{
746 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 747 error (_("object size is larger than varsize-limit"));
714e53ab
PH
748}
749
0963b4bd 750/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 751static LONGEST
c3e5cd34 752max_of_size (int size)
4c4b4cd2 753{
76a01679 754 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 755
76a01679 756 return top_bit | (top_bit - 1);
4c4b4cd2
PH
757}
758
0963b4bd 759/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 760static LONGEST
c3e5cd34 761min_of_size (int size)
4c4b4cd2 762{
c3e5cd34 763 return -max_of_size (size) - 1;
4c4b4cd2
PH
764}
765
0963b4bd 766/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 767static ULONGEST
c3e5cd34 768umax_of_size (int size)
4c4b4cd2 769{
76a01679 770 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 771
76a01679 772 return top_bit | (top_bit - 1);
4c4b4cd2
PH
773}
774
0963b4bd 775/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
776static LONGEST
777max_of_type (struct type *t)
4c4b4cd2 778{
c3e5cd34
PH
779 if (TYPE_UNSIGNED (t))
780 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
781 else
782 return max_of_size (TYPE_LENGTH (t));
783}
784
0963b4bd 785/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
786static LONGEST
787min_of_type (struct type *t)
788{
789 if (TYPE_UNSIGNED (t))
790 return 0;
791 else
792 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
793}
794
795/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
796LONGEST
797ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 798{
c3345124 799 type = resolve_dynamic_type (type, NULL, 0);
76a01679 800 switch (TYPE_CODE (type))
4c4b4cd2
PH
801 {
802 case TYPE_CODE_RANGE:
690cc4eb 803 return TYPE_HIGH_BOUND (type);
4c4b4cd2 804 case TYPE_CODE_ENUM:
14e75d8e 805 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
806 case TYPE_CODE_BOOL:
807 return 1;
808 case TYPE_CODE_CHAR:
76a01679 809 case TYPE_CODE_INT:
690cc4eb 810 return max_of_type (type);
4c4b4cd2 811 default:
43bbcdc2 812 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
813 }
814}
815
14e75d8e 816/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
817LONGEST
818ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 819{
c3345124 820 type = resolve_dynamic_type (type, NULL, 0);
76a01679 821 switch (TYPE_CODE (type))
4c4b4cd2
PH
822 {
823 case TYPE_CODE_RANGE:
690cc4eb 824 return TYPE_LOW_BOUND (type);
4c4b4cd2 825 case TYPE_CODE_ENUM:
14e75d8e 826 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
827 case TYPE_CODE_BOOL:
828 return 0;
829 case TYPE_CODE_CHAR:
76a01679 830 case TYPE_CODE_INT:
690cc4eb 831 return min_of_type (type);
4c4b4cd2 832 default:
43bbcdc2 833 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
834 }
835}
836
837/* The identity on non-range types. For range types, the underlying
76a01679 838 non-range scalar type. */
4c4b4cd2
PH
839
840static struct type *
18af8284 841get_base_type (struct type *type)
4c4b4cd2
PH
842{
843 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
844 {
76a01679
JB
845 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
846 return type;
4c4b4cd2
PH
847 type = TYPE_TARGET_TYPE (type);
848 }
849 return type;
14f9c5c9 850}
41246937
JB
851
852/* Return a decoded version of the given VALUE. This means returning
853 a value whose type is obtained by applying all the GNAT-specific
854 encondings, making the resulting type a static but standard description
855 of the initial type. */
856
857struct value *
858ada_get_decoded_value (struct value *value)
859{
860 struct type *type = ada_check_typedef (value_type (value));
861
862 if (ada_is_array_descriptor_type (type)
863 || (ada_is_constrained_packed_array_type (type)
864 && TYPE_CODE (type) != TYPE_CODE_PTR))
865 {
866 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
867 value = ada_coerce_to_simple_array_ptr (value);
868 else
869 value = ada_coerce_to_simple_array (value);
870 }
871 else
872 value = ada_to_fixed_value (value);
873
874 return value;
875}
876
877/* Same as ada_get_decoded_value, but with the given TYPE.
878 Because there is no associated actual value for this type,
879 the resulting type might be a best-effort approximation in
880 the case of dynamic types. */
881
882struct type *
883ada_get_decoded_type (struct type *type)
884{
885 type = to_static_fixed_type (type);
886 if (ada_is_constrained_packed_array_type (type))
887 type = ada_coerce_to_simple_array_type (type);
888 return type;
889}
890
4c4b4cd2 891\f
76a01679 892
4c4b4cd2 893 /* Language Selection */
14f9c5c9
AS
894
895/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 896 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 897
14f9c5c9 898enum language
ccefe4c4 899ada_update_initial_language (enum language lang)
14f9c5c9 900{
d2e4a39e 901 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 902 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 903 return language_ada;
14f9c5c9
AS
904
905 return lang;
906}
96d887e8
PH
907
908/* If the main procedure is written in Ada, then return its name.
909 The result is good until the next call. Return NULL if the main
910 procedure doesn't appear to be in Ada. */
911
912char *
913ada_main_name (void)
914{
3b7344d5 915 struct bound_minimal_symbol msym;
e83e4e24 916 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 917
96d887e8
PH
918 /* For Ada, the name of the main procedure is stored in a specific
919 string constant, generated by the binder. Look for that symbol,
920 extract its address, and then read that string. If we didn't find
921 that string, then most probably the main procedure is not written
922 in Ada. */
923 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
924
3b7344d5 925 if (msym.minsym != NULL)
96d887e8 926 {
f9bc20b9
JB
927 CORE_ADDR main_program_name_addr;
928 int err_code;
929
77e371c0 930 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 931 if (main_program_name_addr == 0)
323e0a4a 932 error (_("Invalid address for Ada main program name."));
96d887e8 933
f9bc20b9
JB
934 target_read_string (main_program_name_addr, &main_program_name,
935 1024, &err_code);
936
937 if (err_code != 0)
938 return NULL;
e83e4e24 939 return main_program_name.get ();
96d887e8
PH
940 }
941
942 /* The main procedure doesn't seem to be in Ada. */
943 return NULL;
944}
14f9c5c9 945\f
4c4b4cd2 946 /* Symbols */
d2e4a39e 947
4c4b4cd2
PH
948/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
949 of NULLs. */
14f9c5c9 950
d2e4a39e
AS
951const struct ada_opname_map ada_opname_table[] = {
952 {"Oadd", "\"+\"", BINOP_ADD},
953 {"Osubtract", "\"-\"", BINOP_SUB},
954 {"Omultiply", "\"*\"", BINOP_MUL},
955 {"Odivide", "\"/\"", BINOP_DIV},
956 {"Omod", "\"mod\"", BINOP_MOD},
957 {"Orem", "\"rem\"", BINOP_REM},
958 {"Oexpon", "\"**\"", BINOP_EXP},
959 {"Olt", "\"<\"", BINOP_LESS},
960 {"Ole", "\"<=\"", BINOP_LEQ},
961 {"Ogt", "\">\"", BINOP_GTR},
962 {"Oge", "\">=\"", BINOP_GEQ},
963 {"Oeq", "\"=\"", BINOP_EQUAL},
964 {"One", "\"/=\"", BINOP_NOTEQUAL},
965 {"Oand", "\"and\"", BINOP_BITWISE_AND},
966 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
967 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
968 {"Oconcat", "\"&\"", BINOP_CONCAT},
969 {"Oabs", "\"abs\"", UNOP_ABS},
970 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
971 {"Oadd", "\"+\"", UNOP_PLUS},
972 {"Osubtract", "\"-\"", UNOP_NEG},
973 {NULL, NULL}
14f9c5c9
AS
974};
975
b5ec771e
PA
976/* The "encoded" form of DECODED, according to GNAT conventions. The
977 result is valid until the next call to ada_encode. If
978 THROW_ERRORS, throw an error if invalid operator name is found.
979 Otherwise, return NULL in that case. */
4c4b4cd2 980
b5ec771e
PA
981static char *
982ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 983{
4c4b4cd2
PH
984 static char *encoding_buffer = NULL;
985 static size_t encoding_buffer_size = 0;
d2e4a39e 986 const char *p;
14f9c5c9 987 int k;
d2e4a39e 988
4c4b4cd2 989 if (decoded == NULL)
14f9c5c9
AS
990 return NULL;
991
4c4b4cd2
PH
992 GROW_VECT (encoding_buffer, encoding_buffer_size,
993 2 * strlen (decoded) + 10);
14f9c5c9
AS
994
995 k = 0;
4c4b4cd2 996 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 997 {
cdc7bb92 998 if (*p == '.')
4c4b4cd2
PH
999 {
1000 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1001 k += 2;
1002 }
14f9c5c9 1003 else if (*p == '"')
4c4b4cd2
PH
1004 {
1005 const struct ada_opname_map *mapping;
1006
1007 for (mapping = ada_opname_table;
1265e4aa 1008 mapping->encoded != NULL
61012eef 1009 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1010 ;
1011 if (mapping->encoded == NULL)
b5ec771e
PA
1012 {
1013 if (throw_errors)
1014 error (_("invalid Ada operator name: %s"), p);
1015 else
1016 return NULL;
1017 }
4c4b4cd2
PH
1018 strcpy (encoding_buffer + k, mapping->encoded);
1019 k += strlen (mapping->encoded);
1020 break;
1021 }
d2e4a39e 1022 else
4c4b4cd2
PH
1023 {
1024 encoding_buffer[k] = *p;
1025 k += 1;
1026 }
14f9c5c9
AS
1027 }
1028
4c4b4cd2
PH
1029 encoding_buffer[k] = '\0';
1030 return encoding_buffer;
14f9c5c9
AS
1031}
1032
b5ec771e
PA
1033/* The "encoded" form of DECODED, according to GNAT conventions.
1034 The result is valid until the next call to ada_encode. */
1035
1036char *
1037ada_encode (const char *decoded)
1038{
1039 return ada_encode_1 (decoded, true);
1040}
1041
14f9c5c9 1042/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1043 quotes, unfolded, but with the quotes stripped away. Result good
1044 to next call. */
1045
d2e4a39e
AS
1046char *
1047ada_fold_name (const char *name)
14f9c5c9 1048{
d2e4a39e 1049 static char *fold_buffer = NULL;
14f9c5c9
AS
1050 static size_t fold_buffer_size = 0;
1051
1052 int len = strlen (name);
d2e4a39e 1053 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1054
1055 if (name[0] == '\'')
1056 {
d2e4a39e
AS
1057 strncpy (fold_buffer, name + 1, len - 2);
1058 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1059 }
1060 else
1061 {
1062 int i;
5b4ee69b 1063
14f9c5c9 1064 for (i = 0; i <= len; i += 1)
4c4b4cd2 1065 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1066 }
1067
1068 return fold_buffer;
1069}
1070
529cad9c
PH
1071/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1072
1073static int
1074is_lower_alphanum (const char c)
1075{
1076 return (isdigit (c) || (isalpha (c) && islower (c)));
1077}
1078
c90092fe
JB
1079/* ENCODED is the linkage name of a symbol and LEN contains its length.
1080 This function saves in LEN the length of that same symbol name but
1081 without either of these suffixes:
29480c32
JB
1082 . .{DIGIT}+
1083 . ${DIGIT}+
1084 . ___{DIGIT}+
1085 . __{DIGIT}+.
c90092fe 1086
29480c32
JB
1087 These are suffixes introduced by the compiler for entities such as
1088 nested subprogram for instance, in order to avoid name clashes.
1089 They do not serve any purpose for the debugger. */
1090
1091static void
1092ada_remove_trailing_digits (const char *encoded, int *len)
1093{
1094 if (*len > 1 && isdigit (encoded[*len - 1]))
1095 {
1096 int i = *len - 2;
5b4ee69b 1097
29480c32
JB
1098 while (i > 0 && isdigit (encoded[i]))
1099 i--;
1100 if (i >= 0 && encoded[i] == '.')
1101 *len = i;
1102 else if (i >= 0 && encoded[i] == '$')
1103 *len = i;
61012eef 1104 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1105 *len = i - 2;
61012eef 1106 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1107 *len = i - 1;
1108 }
1109}
1110
1111/* Remove the suffix introduced by the compiler for protected object
1112 subprograms. */
1113
1114static void
1115ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1116{
1117 /* Remove trailing N. */
1118
1119 /* Protected entry subprograms are broken into two
1120 separate subprograms: The first one is unprotected, and has
1121 a 'N' suffix; the second is the protected version, and has
0963b4bd 1122 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1123 the protection. Since the P subprograms are internally generated,
1124 we leave these names undecoded, giving the user a clue that this
1125 entity is internal. */
1126
1127 if (*len > 1
1128 && encoded[*len - 1] == 'N'
1129 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1130 *len = *len - 1;
1131}
1132
69fadcdf
JB
1133/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1134
1135static void
1136ada_remove_Xbn_suffix (const char *encoded, int *len)
1137{
1138 int i = *len - 1;
1139
1140 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1141 i--;
1142
1143 if (encoded[i] != 'X')
1144 return;
1145
1146 if (i == 0)
1147 return;
1148
1149 if (isalnum (encoded[i-1]))
1150 *len = i;
1151}
1152
29480c32
JB
1153/* If ENCODED follows the GNAT entity encoding conventions, then return
1154 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1155 replaced by ENCODED.
14f9c5c9 1156
4c4b4cd2 1157 The resulting string is valid until the next call of ada_decode.
29480c32 1158 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1159 is returned. */
1160
1161const char *
1162ada_decode (const char *encoded)
14f9c5c9
AS
1163{
1164 int i, j;
1165 int len0;
d2e4a39e 1166 const char *p;
4c4b4cd2 1167 char *decoded;
14f9c5c9 1168 int at_start_name;
4c4b4cd2
PH
1169 static char *decoding_buffer = NULL;
1170 static size_t decoding_buffer_size = 0;
d2e4a39e 1171
29480c32
JB
1172 /* The name of the Ada main procedure starts with "_ada_".
1173 This prefix is not part of the decoded name, so skip this part
1174 if we see this prefix. */
61012eef 1175 if (startswith (encoded, "_ada_"))
4c4b4cd2 1176 encoded += 5;
14f9c5c9 1177
29480c32
JB
1178 /* If the name starts with '_', then it is not a properly encoded
1179 name, so do not attempt to decode it. Similarly, if the name
1180 starts with '<', the name should not be decoded. */
4c4b4cd2 1181 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1182 goto Suppress;
1183
4c4b4cd2 1184 len0 = strlen (encoded);
4c4b4cd2 1185
29480c32
JB
1186 ada_remove_trailing_digits (encoded, &len0);
1187 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1188
4c4b4cd2
PH
1189 /* Remove the ___X.* suffix if present. Do not forget to verify that
1190 the suffix is located before the current "end" of ENCODED. We want
1191 to avoid re-matching parts of ENCODED that have previously been
1192 marked as discarded (by decrementing LEN0). */
1193 p = strstr (encoded, "___");
1194 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1195 {
1196 if (p[3] == 'X')
4c4b4cd2 1197 len0 = p - encoded;
14f9c5c9 1198 else
4c4b4cd2 1199 goto Suppress;
14f9c5c9 1200 }
4c4b4cd2 1201
29480c32
JB
1202 /* Remove any trailing TKB suffix. It tells us that this symbol
1203 is for the body of a task, but that information does not actually
1204 appear in the decoded name. */
1205
61012eef 1206 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1207 len0 -= 3;
76a01679 1208
a10967fa
JB
1209 /* Remove any trailing TB suffix. The TB suffix is slightly different
1210 from the TKB suffix because it is used for non-anonymous task
1211 bodies. */
1212
61012eef 1213 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1214 len0 -= 2;
1215
29480c32
JB
1216 /* Remove trailing "B" suffixes. */
1217 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1218
61012eef 1219 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1220 len0 -= 1;
1221
4c4b4cd2 1222 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1223
4c4b4cd2
PH
1224 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1225 decoded = decoding_buffer;
14f9c5c9 1226
29480c32
JB
1227 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1228
4c4b4cd2 1229 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1230 {
4c4b4cd2
PH
1231 i = len0 - 2;
1232 while ((i >= 0 && isdigit (encoded[i]))
1233 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1234 i -= 1;
1235 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1236 len0 = i - 1;
1237 else if (encoded[i] == '$')
1238 len0 = i;
d2e4a39e 1239 }
14f9c5c9 1240
29480c32
JB
1241 /* The first few characters that are not alphabetic are not part
1242 of any encoding we use, so we can copy them over verbatim. */
1243
4c4b4cd2
PH
1244 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1245 decoded[j] = encoded[i];
14f9c5c9
AS
1246
1247 at_start_name = 1;
1248 while (i < len0)
1249 {
29480c32 1250 /* Is this a symbol function? */
4c4b4cd2
PH
1251 if (at_start_name && encoded[i] == 'O')
1252 {
1253 int k;
5b4ee69b 1254
4c4b4cd2
PH
1255 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1256 {
1257 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1258 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1259 op_len - 1) == 0)
1260 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1261 {
1262 strcpy (decoded + j, ada_opname_table[k].decoded);
1263 at_start_name = 0;
1264 i += op_len;
1265 j += strlen (ada_opname_table[k].decoded);
1266 break;
1267 }
1268 }
1269 if (ada_opname_table[k].encoded != NULL)
1270 continue;
1271 }
14f9c5c9
AS
1272 at_start_name = 0;
1273
529cad9c
PH
1274 /* Replace "TK__" with "__", which will eventually be translated
1275 into "." (just below). */
1276
61012eef 1277 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1278 i += 2;
529cad9c 1279
29480c32
JB
1280 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1281 be translated into "." (just below). These are internal names
1282 generated for anonymous blocks inside which our symbol is nested. */
1283
1284 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1285 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1286 && isdigit (encoded [i+4]))
1287 {
1288 int k = i + 5;
1289
1290 while (k < len0 && isdigit (encoded[k]))
1291 k++; /* Skip any extra digit. */
1292
1293 /* Double-check that the "__B_{DIGITS}+" sequence we found
1294 is indeed followed by "__". */
1295 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1296 i = k;
1297 }
1298
529cad9c
PH
1299 /* Remove _E{DIGITS}+[sb] */
1300
1301 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1302 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1303 one implements the actual entry code, and has a suffix following
1304 the convention above; the second one implements the barrier and
1305 uses the same convention as above, except that the 'E' is replaced
1306 by a 'B'.
1307
1308 Just as above, we do not decode the name of barrier functions
1309 to give the user a clue that the code he is debugging has been
1310 internally generated. */
1311
1312 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1313 && isdigit (encoded[i+2]))
1314 {
1315 int k = i + 3;
1316
1317 while (k < len0 && isdigit (encoded[k]))
1318 k++;
1319
1320 if (k < len0
1321 && (encoded[k] == 'b' || encoded[k] == 's'))
1322 {
1323 k++;
1324 /* Just as an extra precaution, make sure that if this
1325 suffix is followed by anything else, it is a '_'.
1326 Otherwise, we matched this sequence by accident. */
1327 if (k == len0
1328 || (k < len0 && encoded[k] == '_'))
1329 i = k;
1330 }
1331 }
1332
1333 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1334 the GNAT front-end in protected object subprograms. */
1335
1336 if (i < len0 + 3
1337 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1338 {
1339 /* Backtrack a bit up until we reach either the begining of
1340 the encoded name, or "__". Make sure that we only find
1341 digits or lowercase characters. */
1342 const char *ptr = encoded + i - 1;
1343
1344 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1345 ptr--;
1346 if (ptr < encoded
1347 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1348 i++;
1349 }
1350
4c4b4cd2
PH
1351 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1352 {
29480c32
JB
1353 /* This is a X[bn]* sequence not separated from the previous
1354 part of the name with a non-alpha-numeric character (in other
1355 words, immediately following an alpha-numeric character), then
1356 verify that it is placed at the end of the encoded name. If
1357 not, then the encoding is not valid and we should abort the
1358 decoding. Otherwise, just skip it, it is used in body-nested
1359 package names. */
4c4b4cd2
PH
1360 do
1361 i += 1;
1362 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1363 if (i < len0)
1364 goto Suppress;
1365 }
cdc7bb92 1366 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1367 {
29480c32 1368 /* Replace '__' by '.'. */
4c4b4cd2
PH
1369 decoded[j] = '.';
1370 at_start_name = 1;
1371 i += 2;
1372 j += 1;
1373 }
14f9c5c9 1374 else
4c4b4cd2 1375 {
29480c32
JB
1376 /* It's a character part of the decoded name, so just copy it
1377 over. */
4c4b4cd2
PH
1378 decoded[j] = encoded[i];
1379 i += 1;
1380 j += 1;
1381 }
14f9c5c9 1382 }
4c4b4cd2 1383 decoded[j] = '\000';
14f9c5c9 1384
29480c32
JB
1385 /* Decoded names should never contain any uppercase character.
1386 Double-check this, and abort the decoding if we find one. */
1387
4c4b4cd2
PH
1388 for (i = 0; decoded[i] != '\0'; i += 1)
1389 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1390 goto Suppress;
1391
4c4b4cd2
PH
1392 if (strcmp (decoded, encoded) == 0)
1393 return encoded;
1394 else
1395 return decoded;
14f9c5c9
AS
1396
1397Suppress:
4c4b4cd2
PH
1398 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1399 decoded = decoding_buffer;
1400 if (encoded[0] == '<')
1401 strcpy (decoded, encoded);
14f9c5c9 1402 else
88c15c34 1403 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1404 return decoded;
1405
1406}
1407
1408/* Table for keeping permanent unique copies of decoded names. Once
1409 allocated, names in this table are never released. While this is a
1410 storage leak, it should not be significant unless there are massive
1411 changes in the set of decoded names in successive versions of a
1412 symbol table loaded during a single session. */
1413static struct htab *decoded_names_store;
1414
1415/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1416 in the language-specific part of GSYMBOL, if it has not been
1417 previously computed. Tries to save the decoded name in the same
1418 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1419 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1420 GSYMBOL).
4c4b4cd2
PH
1421 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1422 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1423 when a decoded name is cached in it. */
4c4b4cd2 1424
45e6c716 1425const char *
f85f34ed 1426ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1427{
f85f34ed
TT
1428 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1429 const char **resultp =
615b3f62 1430 &gsymbol->language_specific.demangled_name;
5b4ee69b 1431
f85f34ed 1432 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1433 {
1434 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1435 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1436
f85f34ed 1437 gsymbol->ada_mangled = 1;
5b4ee69b 1438
f85f34ed 1439 if (obstack != NULL)
224c3ddb
SM
1440 *resultp
1441 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1442 else
76a01679 1443 {
f85f34ed
TT
1444 /* Sometimes, we can't find a corresponding objfile, in
1445 which case, we put the result on the heap. Since we only
1446 decode when needed, we hope this usually does not cause a
1447 significant memory leak (FIXME). */
1448
76a01679
JB
1449 char **slot = (char **) htab_find_slot (decoded_names_store,
1450 decoded, INSERT);
5b4ee69b 1451
76a01679
JB
1452 if (*slot == NULL)
1453 *slot = xstrdup (decoded);
1454 *resultp = *slot;
1455 }
4c4b4cd2 1456 }
14f9c5c9 1457
4c4b4cd2
PH
1458 return *resultp;
1459}
76a01679 1460
2c0b251b 1461static char *
76a01679 1462ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1463{
1464 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1465}
1466
8b302db8
TT
1467/* Implement la_sniff_from_mangled_name for Ada. */
1468
1469static int
1470ada_sniff_from_mangled_name (const char *mangled, char **out)
1471{
1472 const char *demangled = ada_decode (mangled);
1473
1474 *out = NULL;
1475
1476 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1477 {
1478 /* Set the gsymbol language to Ada, but still return 0.
1479 Two reasons for that:
1480
1481 1. For Ada, we prefer computing the symbol's decoded name
1482 on the fly rather than pre-compute it, in order to save
1483 memory (Ada projects are typically very large).
1484
1485 2. There are some areas in the definition of the GNAT
1486 encoding where, with a bit of bad luck, we might be able
1487 to decode a non-Ada symbol, generating an incorrect
1488 demangled name (Eg: names ending with "TB" for instance
1489 are identified as task bodies and so stripped from
1490 the decoded name returned).
1491
1492 Returning 1, here, but not setting *DEMANGLED, helps us get a
1493 little bit of the best of both worlds. Because we're last,
1494 we should not affect any of the other languages that were
1495 able to demangle the symbol before us; we get to correctly
1496 tag Ada symbols as such; and even if we incorrectly tagged a
1497 non-Ada symbol, which should be rare, any routing through the
1498 Ada language should be transparent (Ada tries to behave much
1499 like C/C++ with non-Ada symbols). */
1500 return 1;
1501 }
1502
1503 return 0;
1504}
1505
14f9c5c9 1506\f
d2e4a39e 1507
4c4b4cd2 1508 /* Arrays */
14f9c5c9 1509
28c85d6c
JB
1510/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1511 generated by the GNAT compiler to describe the index type used
1512 for each dimension of an array, check whether it follows the latest
1513 known encoding. If not, fix it up to conform to the latest encoding.
1514 Otherwise, do nothing. This function also does nothing if
1515 INDEX_DESC_TYPE is NULL.
1516
1517 The GNAT encoding used to describle the array index type evolved a bit.
1518 Initially, the information would be provided through the name of each
1519 field of the structure type only, while the type of these fields was
1520 described as unspecified and irrelevant. The debugger was then expected
1521 to perform a global type lookup using the name of that field in order
1522 to get access to the full index type description. Because these global
1523 lookups can be very expensive, the encoding was later enhanced to make
1524 the global lookup unnecessary by defining the field type as being
1525 the full index type description.
1526
1527 The purpose of this routine is to allow us to support older versions
1528 of the compiler by detecting the use of the older encoding, and by
1529 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1530 we essentially replace each field's meaningless type by the associated
1531 index subtype). */
1532
1533void
1534ada_fixup_array_indexes_type (struct type *index_desc_type)
1535{
1536 int i;
1537
1538 if (index_desc_type == NULL)
1539 return;
1540 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1541
1542 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1543 to check one field only, no need to check them all). If not, return
1544 now.
1545
1546 If our INDEX_DESC_TYPE was generated using the older encoding,
1547 the field type should be a meaningless integer type whose name
1548 is not equal to the field name. */
1549 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1550 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1551 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1552 return;
1553
1554 /* Fixup each field of INDEX_DESC_TYPE. */
1555 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1556 {
0d5cff50 1557 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1558 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1559
1560 if (raw_type)
1561 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1562 }
1563}
1564
4c4b4cd2 1565/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1566
a121b7c1 1567static const char *bound_name[] = {
d2e4a39e 1568 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1569 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1570};
1571
1572/* Maximum number of array dimensions we are prepared to handle. */
1573
4c4b4cd2 1574#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1575
14f9c5c9 1576
4c4b4cd2
PH
1577/* The desc_* routines return primitive portions of array descriptors
1578 (fat pointers). */
14f9c5c9
AS
1579
1580/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1581 level of indirection, if needed. */
1582
d2e4a39e
AS
1583static struct type *
1584desc_base_type (struct type *type)
14f9c5c9
AS
1585{
1586 if (type == NULL)
1587 return NULL;
61ee279c 1588 type = ada_check_typedef (type);
720d1a40
JB
1589 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1590 type = ada_typedef_target_type (type);
1591
1265e4aa
JB
1592 if (type != NULL
1593 && (TYPE_CODE (type) == TYPE_CODE_PTR
1594 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1595 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1596 else
1597 return type;
1598}
1599
4c4b4cd2
PH
1600/* True iff TYPE indicates a "thin" array pointer type. */
1601
14f9c5c9 1602static int
d2e4a39e 1603is_thin_pntr (struct type *type)
14f9c5c9 1604{
d2e4a39e 1605 return
14f9c5c9
AS
1606 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1607 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1608}
1609
4c4b4cd2
PH
1610/* The descriptor type for thin pointer type TYPE. */
1611
d2e4a39e
AS
1612static struct type *
1613thin_descriptor_type (struct type *type)
14f9c5c9 1614{
d2e4a39e 1615 struct type *base_type = desc_base_type (type);
5b4ee69b 1616
14f9c5c9
AS
1617 if (base_type == NULL)
1618 return NULL;
1619 if (is_suffix (ada_type_name (base_type), "___XVE"))
1620 return base_type;
d2e4a39e 1621 else
14f9c5c9 1622 {
d2e4a39e 1623 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1624
14f9c5c9 1625 if (alt_type == NULL)
4c4b4cd2 1626 return base_type;
14f9c5c9 1627 else
4c4b4cd2 1628 return alt_type;
14f9c5c9
AS
1629 }
1630}
1631
4c4b4cd2
PH
1632/* A pointer to the array data for thin-pointer value VAL. */
1633
d2e4a39e
AS
1634static struct value *
1635thin_data_pntr (struct value *val)
14f9c5c9 1636{
828292f2 1637 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1638 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1639
556bdfd4
UW
1640 data_type = lookup_pointer_type (data_type);
1641
14f9c5c9 1642 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1643 return value_cast (data_type, value_copy (val));
d2e4a39e 1644 else
42ae5230 1645 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1646}
1647
4c4b4cd2
PH
1648/* True iff TYPE indicates a "thick" array pointer type. */
1649
14f9c5c9 1650static int
d2e4a39e 1651is_thick_pntr (struct type *type)
14f9c5c9
AS
1652{
1653 type = desc_base_type (type);
1654 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1655 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1656}
1657
4c4b4cd2
PH
1658/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1659 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1660
d2e4a39e
AS
1661static struct type *
1662desc_bounds_type (struct type *type)
14f9c5c9 1663{
d2e4a39e 1664 struct type *r;
14f9c5c9
AS
1665
1666 type = desc_base_type (type);
1667
1668 if (type == NULL)
1669 return NULL;
1670 else if (is_thin_pntr (type))
1671 {
1672 type = thin_descriptor_type (type);
1673 if (type == NULL)
4c4b4cd2 1674 return NULL;
14f9c5c9
AS
1675 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1676 if (r != NULL)
61ee279c 1677 return ada_check_typedef (r);
14f9c5c9
AS
1678 }
1679 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1680 {
1681 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1682 if (r != NULL)
61ee279c 1683 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1684 }
1685 return NULL;
1686}
1687
1688/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1689 one, a pointer to its bounds data. Otherwise NULL. */
1690
d2e4a39e
AS
1691static struct value *
1692desc_bounds (struct value *arr)
14f9c5c9 1693{
df407dfe 1694 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1695
d2e4a39e 1696 if (is_thin_pntr (type))
14f9c5c9 1697 {
d2e4a39e 1698 struct type *bounds_type =
4c4b4cd2 1699 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1700 LONGEST addr;
1701
4cdfadb1 1702 if (bounds_type == NULL)
323e0a4a 1703 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1704
1705 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1706 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1707 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1708 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1709 addr = value_as_long (arr);
d2e4a39e 1710 else
42ae5230 1711 addr = value_address (arr);
14f9c5c9 1712
d2e4a39e 1713 return
4c4b4cd2
PH
1714 value_from_longest (lookup_pointer_type (bounds_type),
1715 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1716 }
1717
1718 else if (is_thick_pntr (type))
05e522ef
JB
1719 {
1720 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1721 _("Bad GNAT array descriptor"));
1722 struct type *p_bounds_type = value_type (p_bounds);
1723
1724 if (p_bounds_type
1725 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1726 {
1727 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1728
1729 if (TYPE_STUB (target_type))
1730 p_bounds = value_cast (lookup_pointer_type
1731 (ada_check_typedef (target_type)),
1732 p_bounds);
1733 }
1734 else
1735 error (_("Bad GNAT array descriptor"));
1736
1737 return p_bounds;
1738 }
14f9c5c9
AS
1739 else
1740 return NULL;
1741}
1742
4c4b4cd2
PH
1743/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1744 position of the field containing the address of the bounds data. */
1745
14f9c5c9 1746static int
d2e4a39e 1747fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1748{
1749 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1750}
1751
1752/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1753 size of the field containing the address of the bounds data. */
1754
14f9c5c9 1755static int
d2e4a39e 1756fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1757{
1758 type = desc_base_type (type);
1759
d2e4a39e 1760 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1761 return TYPE_FIELD_BITSIZE (type, 1);
1762 else
61ee279c 1763 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1764}
1765
4c4b4cd2 1766/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1767 pointer to one, the type of its array data (a array-with-no-bounds type);
1768 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1769 data. */
4c4b4cd2 1770
d2e4a39e 1771static struct type *
556bdfd4 1772desc_data_target_type (struct type *type)
14f9c5c9
AS
1773{
1774 type = desc_base_type (type);
1775
4c4b4cd2 1776 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1777 if (is_thin_pntr (type))
556bdfd4 1778 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1779 else if (is_thick_pntr (type))
556bdfd4
UW
1780 {
1781 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1782
1783 if (data_type
1784 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1785 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1786 }
1787
1788 return NULL;
14f9c5c9
AS
1789}
1790
1791/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1792 its array data. */
4c4b4cd2 1793
d2e4a39e
AS
1794static struct value *
1795desc_data (struct value *arr)
14f9c5c9 1796{
df407dfe 1797 struct type *type = value_type (arr);
5b4ee69b 1798
14f9c5c9
AS
1799 if (is_thin_pntr (type))
1800 return thin_data_pntr (arr);
1801 else if (is_thick_pntr (type))
d2e4a39e 1802 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1803 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1804 else
1805 return NULL;
1806}
1807
1808
1809/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1810 position of the field containing the address of the data. */
1811
14f9c5c9 1812static int
d2e4a39e 1813fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1814{
1815 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1816}
1817
1818/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1819 size of the field containing the address of the data. */
1820
14f9c5c9 1821static int
d2e4a39e 1822fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1823{
1824 type = desc_base_type (type);
1825
1826 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1827 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1828 else
14f9c5c9
AS
1829 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1830}
1831
4c4b4cd2 1832/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1833 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1834 bound, if WHICH is 1. The first bound is I=1. */
1835
d2e4a39e
AS
1836static struct value *
1837desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1838{
d2e4a39e 1839 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1840 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1841}
1842
1843/* If BOUNDS is an array-bounds structure type, return the bit position
1844 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1845 bound, if WHICH is 1. The first bound is I=1. */
1846
14f9c5c9 1847static int
d2e4a39e 1848desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1849{
d2e4a39e 1850 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1851}
1852
1853/* If BOUNDS is an array-bounds structure type, return the bit field size
1854 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1855 bound, if WHICH is 1. The first bound is I=1. */
1856
76a01679 1857static int
d2e4a39e 1858desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1859{
1860 type = desc_base_type (type);
1861
d2e4a39e
AS
1862 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1863 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1864 else
1865 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1866}
1867
1868/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1869 Ith bound (numbering from 1). Otherwise, NULL. */
1870
d2e4a39e
AS
1871static struct type *
1872desc_index_type (struct type *type, int i)
14f9c5c9
AS
1873{
1874 type = desc_base_type (type);
1875
1876 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1877 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1878 else
14f9c5c9
AS
1879 return NULL;
1880}
1881
4c4b4cd2
PH
1882/* The number of index positions in the array-bounds type TYPE.
1883 Return 0 if TYPE is NULL. */
1884
14f9c5c9 1885static int
d2e4a39e 1886desc_arity (struct type *type)
14f9c5c9
AS
1887{
1888 type = desc_base_type (type);
1889
1890 if (type != NULL)
1891 return TYPE_NFIELDS (type) / 2;
1892 return 0;
1893}
1894
4c4b4cd2
PH
1895/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1896 an array descriptor type (representing an unconstrained array
1897 type). */
1898
76a01679
JB
1899static int
1900ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1901{
1902 if (type == NULL)
1903 return 0;
61ee279c 1904 type = ada_check_typedef (type);
4c4b4cd2 1905 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1906 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1907}
1908
52ce6436 1909/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1910 * to one. */
52ce6436 1911
2c0b251b 1912static int
52ce6436
PH
1913ada_is_array_type (struct type *type)
1914{
1915 while (type != NULL
1916 && (TYPE_CODE (type) == TYPE_CODE_PTR
1917 || TYPE_CODE (type) == TYPE_CODE_REF))
1918 type = TYPE_TARGET_TYPE (type);
1919 return ada_is_direct_array_type (type);
1920}
1921
4c4b4cd2 1922/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1923
14f9c5c9 1924int
4c4b4cd2 1925ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1926{
1927 if (type == NULL)
1928 return 0;
61ee279c 1929 type = ada_check_typedef (type);
14f9c5c9 1930 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1931 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1932 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1933 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1934}
1935
4c4b4cd2
PH
1936/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1937
14f9c5c9 1938int
4c4b4cd2 1939ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1940{
556bdfd4 1941 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1942
1943 if (type == NULL)
1944 return 0;
61ee279c 1945 type = ada_check_typedef (type);
556bdfd4
UW
1946 return (data_type != NULL
1947 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1948 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1949}
1950
1951/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1952 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1953 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1954 is still needed. */
1955
14f9c5c9 1956int
ebf56fd3 1957ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1958{
d2e4a39e 1959 return
14f9c5c9
AS
1960 type != NULL
1961 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1962 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1963 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1964 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1965}
1966
1967
4c4b4cd2 1968/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1969 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1970 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1971 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1972 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1973 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1974 a descriptor. */
d2e4a39e
AS
1975struct type *
1976ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1977{
ad82864c
JB
1978 if (ada_is_constrained_packed_array_type (value_type (arr)))
1979 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1980
df407dfe
AC
1981 if (!ada_is_array_descriptor_type (value_type (arr)))
1982 return value_type (arr);
d2e4a39e
AS
1983
1984 if (!bounds)
ad82864c
JB
1985 {
1986 struct type *array_type =
1987 ada_check_typedef (desc_data_target_type (value_type (arr)));
1988
1989 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1990 TYPE_FIELD_BITSIZE (array_type, 0) =
1991 decode_packed_array_bitsize (value_type (arr));
1992
1993 return array_type;
1994 }
14f9c5c9
AS
1995 else
1996 {
d2e4a39e 1997 struct type *elt_type;
14f9c5c9 1998 int arity;
d2e4a39e 1999 struct value *descriptor;
14f9c5c9 2000
df407dfe
AC
2001 elt_type = ada_array_element_type (value_type (arr), -1);
2002 arity = ada_array_arity (value_type (arr));
14f9c5c9 2003
d2e4a39e 2004 if (elt_type == NULL || arity == 0)
df407dfe 2005 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2006
2007 descriptor = desc_bounds (arr);
d2e4a39e 2008 if (value_as_long (descriptor) == 0)
4c4b4cd2 2009 return NULL;
d2e4a39e 2010 while (arity > 0)
4c4b4cd2 2011 {
e9bb382b
UW
2012 struct type *range_type = alloc_type_copy (value_type (arr));
2013 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2014 struct value *low = desc_one_bound (descriptor, arity, 0);
2015 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2016
5b4ee69b 2017 arity -= 1;
0c9c3474
SA
2018 create_static_range_type (range_type, value_type (low),
2019 longest_to_int (value_as_long (low)),
2020 longest_to_int (value_as_long (high)));
4c4b4cd2 2021 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2022
2023 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2024 {
2025 /* We need to store the element packed bitsize, as well as
2026 recompute the array size, because it was previously
2027 computed based on the unpacked element size. */
2028 LONGEST lo = value_as_long (low);
2029 LONGEST hi = value_as_long (high);
2030
2031 TYPE_FIELD_BITSIZE (elt_type, 0) =
2032 decode_packed_array_bitsize (value_type (arr));
2033 /* If the array has no element, then the size is already
2034 zero, and does not need to be recomputed. */
2035 if (lo < hi)
2036 {
2037 int array_bitsize =
2038 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2039
2040 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2041 }
2042 }
4c4b4cd2 2043 }
14f9c5c9
AS
2044
2045 return lookup_pointer_type (elt_type);
2046 }
2047}
2048
2049/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2050 Otherwise, returns either a standard GDB array with bounds set
2051 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2052 GDB array. Returns NULL if ARR is a null fat pointer. */
2053
d2e4a39e
AS
2054struct value *
2055ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2056{
df407dfe 2057 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2058 {
d2e4a39e 2059 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2060
14f9c5c9 2061 if (arrType == NULL)
4c4b4cd2 2062 return NULL;
14f9c5c9
AS
2063 return value_cast (arrType, value_copy (desc_data (arr)));
2064 }
ad82864c
JB
2065 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2066 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2067 else
2068 return arr;
2069}
2070
2071/* If ARR does not represent an array, returns ARR unchanged.
2072 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2073 be ARR itself if it already is in the proper form). */
2074
720d1a40 2075struct value *
d2e4a39e 2076ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2077{
df407dfe 2078 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2079 {
d2e4a39e 2080 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2081
14f9c5c9 2082 if (arrVal == NULL)
323e0a4a 2083 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2084 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2085 return value_ind (arrVal);
2086 }
ad82864c
JB
2087 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2088 return decode_constrained_packed_array (arr);
d2e4a39e 2089 else
14f9c5c9
AS
2090 return arr;
2091}
2092
2093/* If TYPE represents a GNAT array type, return it translated to an
2094 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2095 packing). For other types, is the identity. */
2096
d2e4a39e
AS
2097struct type *
2098ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2099{
ad82864c
JB
2100 if (ada_is_constrained_packed_array_type (type))
2101 return decode_constrained_packed_array_type (type);
17280b9f
UW
2102
2103 if (ada_is_array_descriptor_type (type))
556bdfd4 2104 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2105
2106 return type;
14f9c5c9
AS
2107}
2108
4c4b4cd2
PH
2109/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2110
ad82864c
JB
2111static int
2112ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2113{
2114 if (type == NULL)
2115 return 0;
4c4b4cd2 2116 type = desc_base_type (type);
61ee279c 2117 type = ada_check_typedef (type);
d2e4a39e 2118 return
14f9c5c9
AS
2119 ada_type_name (type) != NULL
2120 && strstr (ada_type_name (type), "___XP") != NULL;
2121}
2122
ad82864c
JB
2123/* Non-zero iff TYPE represents a standard GNAT constrained
2124 packed-array type. */
2125
2126int
2127ada_is_constrained_packed_array_type (struct type *type)
2128{
2129 return ada_is_packed_array_type (type)
2130 && !ada_is_array_descriptor_type (type);
2131}
2132
2133/* Non-zero iff TYPE represents an array descriptor for a
2134 unconstrained packed-array type. */
2135
2136static int
2137ada_is_unconstrained_packed_array_type (struct type *type)
2138{
2139 return ada_is_packed_array_type (type)
2140 && ada_is_array_descriptor_type (type);
2141}
2142
2143/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2144 return the size of its elements in bits. */
2145
2146static long
2147decode_packed_array_bitsize (struct type *type)
2148{
0d5cff50
DE
2149 const char *raw_name;
2150 const char *tail;
ad82864c
JB
2151 long bits;
2152
720d1a40
JB
2153 /* Access to arrays implemented as fat pointers are encoded as a typedef
2154 of the fat pointer type. We need the name of the fat pointer type
2155 to do the decoding, so strip the typedef layer. */
2156 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2157 type = ada_typedef_target_type (type);
2158
2159 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2160 if (!raw_name)
2161 raw_name = ada_type_name (desc_base_type (type));
2162
2163 if (!raw_name)
2164 return 0;
2165
2166 tail = strstr (raw_name, "___XP");
720d1a40 2167 gdb_assert (tail != NULL);
ad82864c
JB
2168
2169 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2170 {
2171 lim_warning
2172 (_("could not understand bit size information on packed array"));
2173 return 0;
2174 }
2175
2176 return bits;
2177}
2178
14f9c5c9
AS
2179/* Given that TYPE is a standard GDB array type with all bounds filled
2180 in, and that the element size of its ultimate scalar constituents
2181 (that is, either its elements, or, if it is an array of arrays, its
2182 elements' elements, etc.) is *ELT_BITS, return an identical type,
2183 but with the bit sizes of its elements (and those of any
2184 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2185 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2186 in bits.
2187
2188 Note that, for arrays whose index type has an XA encoding where
2189 a bound references a record discriminant, getting that discriminant,
2190 and therefore the actual value of that bound, is not possible
2191 because none of the given parameters gives us access to the record.
2192 This function assumes that it is OK in the context where it is being
2193 used to return an array whose bounds are still dynamic and where
2194 the length is arbitrary. */
4c4b4cd2 2195
d2e4a39e 2196static struct type *
ad82864c 2197constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2198{
d2e4a39e
AS
2199 struct type *new_elt_type;
2200 struct type *new_type;
99b1c762
JB
2201 struct type *index_type_desc;
2202 struct type *index_type;
14f9c5c9
AS
2203 LONGEST low_bound, high_bound;
2204
61ee279c 2205 type = ada_check_typedef (type);
14f9c5c9
AS
2206 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2207 return type;
2208
99b1c762
JB
2209 index_type_desc = ada_find_parallel_type (type, "___XA");
2210 if (index_type_desc)
2211 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2212 NULL);
2213 else
2214 index_type = TYPE_INDEX_TYPE (type);
2215
e9bb382b 2216 new_type = alloc_type_copy (type);
ad82864c
JB
2217 new_elt_type =
2218 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2219 elt_bits);
99b1c762 2220 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2221 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2222 TYPE_NAME (new_type) = ada_type_name (type);
2223
4a46959e
JB
2224 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2225 && is_dynamic_type (check_typedef (index_type)))
2226 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2227 low_bound = high_bound = 0;
2228 if (high_bound < low_bound)
2229 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2230 else
14f9c5c9
AS
2231 {
2232 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2233 TYPE_LENGTH (new_type) =
4c4b4cd2 2234 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2235 }
2236
876cecd0 2237 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2238 return new_type;
2239}
2240
ad82864c
JB
2241/* The array type encoded by TYPE, where
2242 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2243
d2e4a39e 2244static struct type *
ad82864c 2245decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2246{
0d5cff50 2247 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2248 char *name;
0d5cff50 2249 const char *tail;
d2e4a39e 2250 struct type *shadow_type;
14f9c5c9 2251 long bits;
14f9c5c9 2252
727e3d2e
JB
2253 if (!raw_name)
2254 raw_name = ada_type_name (desc_base_type (type));
2255
2256 if (!raw_name)
2257 return NULL;
2258
2259 name = (char *) alloca (strlen (raw_name) + 1);
2260 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2261 type = desc_base_type (type);
2262
14f9c5c9
AS
2263 memcpy (name, raw_name, tail - raw_name);
2264 name[tail - raw_name] = '\000';
2265
b4ba55a1
JB
2266 shadow_type = ada_find_parallel_type_with_name (type, name);
2267
2268 if (shadow_type == NULL)
14f9c5c9 2269 {
323e0a4a 2270 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2271 return NULL;
2272 }
f168693b 2273 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2274
2275 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2276 {
0963b4bd
MS
2277 lim_warning (_("could not understand bounds "
2278 "information on packed array"));
14f9c5c9
AS
2279 return NULL;
2280 }
d2e4a39e 2281
ad82864c
JB
2282 bits = decode_packed_array_bitsize (type);
2283 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2284}
2285
ad82864c
JB
2286/* Given that ARR is a struct value *indicating a GNAT constrained packed
2287 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2288 standard GDB array type except that the BITSIZEs of the array
2289 target types are set to the number of bits in each element, and the
4c4b4cd2 2290 type length is set appropriately. */
14f9c5c9 2291
d2e4a39e 2292static struct value *
ad82864c 2293decode_constrained_packed_array (struct value *arr)
14f9c5c9 2294{
4c4b4cd2 2295 struct type *type;
14f9c5c9 2296
11aa919a
PMR
2297 /* If our value is a pointer, then dereference it. Likewise if
2298 the value is a reference. Make sure that this operation does not
2299 cause the target type to be fixed, as this would indirectly cause
2300 this array to be decoded. The rest of the routine assumes that
2301 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2302 and "value_ind" routines to perform the dereferencing, as opposed
2303 to using "ada_coerce_ref" or "ada_value_ind". */
2304 arr = coerce_ref (arr);
828292f2 2305 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2306 arr = value_ind (arr);
4c4b4cd2 2307
ad82864c 2308 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2309 if (type == NULL)
2310 {
323e0a4a 2311 error (_("can't unpack array"));
14f9c5c9
AS
2312 return NULL;
2313 }
61ee279c 2314
50810684 2315 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2316 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2317 {
2318 /* This is a (right-justified) modular type representing a packed
2319 array with no wrapper. In order to interpret the value through
2320 the (left-justified) packed array type we just built, we must
2321 first left-justify it. */
2322 int bit_size, bit_pos;
2323 ULONGEST mod;
2324
df407dfe 2325 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2326 bit_size = 0;
2327 while (mod > 0)
2328 {
2329 bit_size += 1;
2330 mod >>= 1;
2331 }
df407dfe 2332 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2333 arr = ada_value_primitive_packed_val (arr, NULL,
2334 bit_pos / HOST_CHAR_BIT,
2335 bit_pos % HOST_CHAR_BIT,
2336 bit_size,
2337 type);
2338 }
2339
4c4b4cd2 2340 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2341}
2342
2343
2344/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2345 given in IND. ARR must be a simple array. */
14f9c5c9 2346
d2e4a39e
AS
2347static struct value *
2348value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2349{
2350 int i;
2351 int bits, elt_off, bit_off;
2352 long elt_total_bit_offset;
d2e4a39e
AS
2353 struct type *elt_type;
2354 struct value *v;
14f9c5c9
AS
2355
2356 bits = 0;
2357 elt_total_bit_offset = 0;
df407dfe 2358 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2359 for (i = 0; i < arity; i += 1)
14f9c5c9 2360 {
d2e4a39e 2361 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2362 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2363 error
0963b4bd
MS
2364 (_("attempt to do packed indexing of "
2365 "something other than a packed array"));
14f9c5c9 2366 else
4c4b4cd2
PH
2367 {
2368 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2369 LONGEST lowerbound, upperbound;
2370 LONGEST idx;
2371
2372 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2373 {
323e0a4a 2374 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2375 lowerbound = upperbound = 0;
2376 }
2377
3cb382c9 2378 idx = pos_atr (ind[i]);
4c4b4cd2 2379 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2380 lim_warning (_("packed array index %ld out of bounds"),
2381 (long) idx);
4c4b4cd2
PH
2382 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2383 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2384 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2385 }
14f9c5c9
AS
2386 }
2387 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2388 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2389
2390 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2391 bits, elt_type);
14f9c5c9
AS
2392 return v;
2393}
2394
4c4b4cd2 2395/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2396
2397static int
d2e4a39e 2398has_negatives (struct type *type)
14f9c5c9 2399{
d2e4a39e
AS
2400 switch (TYPE_CODE (type))
2401 {
2402 default:
2403 return 0;
2404 case TYPE_CODE_INT:
2405 return !TYPE_UNSIGNED (type);
2406 case TYPE_CODE_RANGE:
2407 return TYPE_LOW_BOUND (type) < 0;
2408 }
14f9c5c9 2409}
d2e4a39e 2410
f93fca70 2411/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2412 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2413 the unpacked buffer.
14f9c5c9 2414
5b639dea
JB
2415 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2416 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2417
f93fca70
JB
2418 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2419 zero otherwise.
14f9c5c9 2420
f93fca70 2421 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2422
f93fca70
JB
2423 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2424
2425static void
2426ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2427 gdb_byte *unpacked, int unpacked_len,
2428 int is_big_endian, int is_signed_type,
2429 int is_scalar)
2430{
a1c95e6b
JB
2431 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2432 int src_idx; /* Index into the source area */
2433 int src_bytes_left; /* Number of source bytes left to process. */
2434 int srcBitsLeft; /* Number of source bits left to move */
2435 int unusedLS; /* Number of bits in next significant
2436 byte of source that are unused */
2437
a1c95e6b
JB
2438 int unpacked_idx; /* Index into the unpacked buffer */
2439 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2440
4c4b4cd2 2441 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2442 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2443 unsigned char sign;
a1c95e6b 2444
4c4b4cd2
PH
2445 /* Transmit bytes from least to most significant; delta is the direction
2446 the indices move. */
f93fca70 2447 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2448
5b639dea
JB
2449 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2450 bits from SRC. .*/
2451 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2452 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2453 bit_size, unpacked_len);
2454
14f9c5c9 2455 srcBitsLeft = bit_size;
086ca51f 2456 src_bytes_left = src_len;
f93fca70 2457 unpacked_bytes_left = unpacked_len;
14f9c5c9 2458 sign = 0;
f93fca70
JB
2459
2460 if (is_big_endian)
14f9c5c9 2461 {
086ca51f 2462 src_idx = src_len - 1;
f93fca70
JB
2463 if (is_signed_type
2464 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2465 sign = ~0;
d2e4a39e
AS
2466
2467 unusedLS =
4c4b4cd2
PH
2468 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2469 % HOST_CHAR_BIT;
14f9c5c9 2470
f93fca70
JB
2471 if (is_scalar)
2472 {
2473 accumSize = 0;
2474 unpacked_idx = unpacked_len - 1;
2475 }
2476 else
2477 {
4c4b4cd2
PH
2478 /* Non-scalar values must be aligned at a byte boundary... */
2479 accumSize =
2480 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2481 /* ... And are placed at the beginning (most-significant) bytes
2482 of the target. */
086ca51f
JB
2483 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2484 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2485 }
14f9c5c9 2486 }
d2e4a39e 2487 else
14f9c5c9
AS
2488 {
2489 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2490
086ca51f 2491 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2492 unusedLS = bit_offset;
2493 accumSize = 0;
2494
f93fca70 2495 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2496 sign = ~0;
14f9c5c9 2497 }
d2e4a39e 2498
14f9c5c9 2499 accum = 0;
086ca51f 2500 while (src_bytes_left > 0)
14f9c5c9
AS
2501 {
2502 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2503 part of the value. */
d2e4a39e 2504 unsigned int unusedMSMask =
4c4b4cd2
PH
2505 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2506 1;
2507 /* Sign-extend bits for this byte. */
14f9c5c9 2508 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2509
d2e4a39e 2510 accum |=
086ca51f 2511 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2512 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2513 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2514 {
db297a65 2515 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2516 accumSize -= HOST_CHAR_BIT;
2517 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2518 unpacked_bytes_left -= 1;
2519 unpacked_idx += delta;
4c4b4cd2 2520 }
14f9c5c9
AS
2521 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2522 unusedLS = 0;
086ca51f
JB
2523 src_bytes_left -= 1;
2524 src_idx += delta;
14f9c5c9 2525 }
086ca51f 2526 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2527 {
2528 accum |= sign << accumSize;
db297a65 2529 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2530 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2531 if (accumSize < 0)
2532 accumSize = 0;
14f9c5c9 2533 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2534 unpacked_bytes_left -= 1;
2535 unpacked_idx += delta;
14f9c5c9 2536 }
f93fca70
JB
2537}
2538
2539/* Create a new value of type TYPE from the contents of OBJ starting
2540 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2541 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2542 assigning through the result will set the field fetched from.
2543 VALADDR is ignored unless OBJ is NULL, in which case,
2544 VALADDR+OFFSET must address the start of storage containing the
2545 packed value. The value returned in this case is never an lval.
2546 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2547
2548struct value *
2549ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2550 long offset, int bit_offset, int bit_size,
2551 struct type *type)
2552{
2553 struct value *v;
bfb1c796 2554 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2555 gdb_byte *unpacked;
220475ed 2556 const int is_scalar = is_scalar_type (type);
d0a9e810 2557 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2558 gdb::byte_vector staging;
f93fca70
JB
2559
2560 type = ada_check_typedef (type);
2561
d0a9e810 2562 if (obj == NULL)
bfb1c796 2563 src = valaddr + offset;
d0a9e810 2564 else
bfb1c796 2565 src = value_contents (obj) + offset;
d0a9e810
JB
2566
2567 if (is_dynamic_type (type))
2568 {
2569 /* The length of TYPE might by dynamic, so we need to resolve
2570 TYPE in order to know its actual size, which we then use
2571 to create the contents buffer of the value we return.
2572 The difficulty is that the data containing our object is
2573 packed, and therefore maybe not at a byte boundary. So, what
2574 we do, is unpack the data into a byte-aligned buffer, and then
2575 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2576 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2577 staging.resize (staging_len);
d0a9e810
JB
2578
2579 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2580 staging.data (), staging.size (),
d0a9e810
JB
2581 is_big_endian, has_negatives (type),
2582 is_scalar);
d5722aa2 2583 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2584 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2585 {
2586 /* This happens when the length of the object is dynamic,
2587 and is actually smaller than the space reserved for it.
2588 For instance, in an array of variant records, the bit_size
2589 we're given is the array stride, which is constant and
2590 normally equal to the maximum size of its element.
2591 But, in reality, each element only actually spans a portion
2592 of that stride. */
2593 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2594 }
d0a9e810
JB
2595 }
2596
f93fca70
JB
2597 if (obj == NULL)
2598 {
2599 v = allocate_value (type);
bfb1c796 2600 src = valaddr + offset;
f93fca70
JB
2601 }
2602 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2603 {
0cafa88c 2604 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2605 gdb_byte *buf;
0cafa88c 2606
f93fca70 2607 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2608 buf = (gdb_byte *) alloca (src_len);
2609 read_memory (value_address (v), buf, src_len);
2610 src = buf;
f93fca70
JB
2611 }
2612 else
2613 {
2614 v = allocate_value (type);
bfb1c796 2615 src = value_contents (obj) + offset;
f93fca70
JB
2616 }
2617
2618 if (obj != NULL)
2619 {
2620 long new_offset = offset;
2621
2622 set_value_component_location (v, obj);
2623 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2624 set_value_bitsize (v, bit_size);
2625 if (value_bitpos (v) >= HOST_CHAR_BIT)
2626 {
2627 ++new_offset;
2628 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2629 }
2630 set_value_offset (v, new_offset);
2631
2632 /* Also set the parent value. This is needed when trying to
2633 assign a new value (in inferior memory). */
2634 set_value_parent (v, obj);
2635 }
2636 else
2637 set_value_bitsize (v, bit_size);
bfb1c796 2638 unpacked = value_contents_writeable (v);
f93fca70
JB
2639
2640 if (bit_size == 0)
2641 {
2642 memset (unpacked, 0, TYPE_LENGTH (type));
2643 return v;
2644 }
2645
d5722aa2 2646 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2647 {
d0a9e810
JB
2648 /* Small short-cut: If we've unpacked the data into a buffer
2649 of the same size as TYPE's length, then we can reuse that,
2650 instead of doing the unpacking again. */
d5722aa2 2651 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2652 }
d0a9e810
JB
2653 else
2654 ada_unpack_from_contents (src, bit_offset, bit_size,
2655 unpacked, TYPE_LENGTH (type),
2656 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2657
14f9c5c9
AS
2658 return v;
2659}
d2e4a39e 2660
14f9c5c9
AS
2661/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2662 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2663 not overlap. */
14f9c5c9 2664static void
fc1a4b47 2665move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2666 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2667{
2668 unsigned int accum, mask;
2669 int accum_bits, chunk_size;
2670
2671 target += targ_offset / HOST_CHAR_BIT;
2672 targ_offset %= HOST_CHAR_BIT;
2673 source += src_offset / HOST_CHAR_BIT;
2674 src_offset %= HOST_CHAR_BIT;
50810684 2675 if (bits_big_endian_p)
14f9c5c9
AS
2676 {
2677 accum = (unsigned char) *source;
2678 source += 1;
2679 accum_bits = HOST_CHAR_BIT - src_offset;
2680
d2e4a39e 2681 while (n > 0)
4c4b4cd2
PH
2682 {
2683 int unused_right;
5b4ee69b 2684
4c4b4cd2
PH
2685 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2686 accum_bits += HOST_CHAR_BIT;
2687 source += 1;
2688 chunk_size = HOST_CHAR_BIT - targ_offset;
2689 if (chunk_size > n)
2690 chunk_size = n;
2691 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2692 mask = ((1 << chunk_size) - 1) << unused_right;
2693 *target =
2694 (*target & ~mask)
2695 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2696 n -= chunk_size;
2697 accum_bits -= chunk_size;
2698 target += 1;
2699 targ_offset = 0;
2700 }
14f9c5c9
AS
2701 }
2702 else
2703 {
2704 accum = (unsigned char) *source >> src_offset;
2705 source += 1;
2706 accum_bits = HOST_CHAR_BIT - src_offset;
2707
d2e4a39e 2708 while (n > 0)
4c4b4cd2
PH
2709 {
2710 accum = accum + ((unsigned char) *source << accum_bits);
2711 accum_bits += HOST_CHAR_BIT;
2712 source += 1;
2713 chunk_size = HOST_CHAR_BIT - targ_offset;
2714 if (chunk_size > n)
2715 chunk_size = n;
2716 mask = ((1 << chunk_size) - 1) << targ_offset;
2717 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2718 n -= chunk_size;
2719 accum_bits -= chunk_size;
2720 accum >>= chunk_size;
2721 target += 1;
2722 targ_offset = 0;
2723 }
14f9c5c9
AS
2724 }
2725}
2726
14f9c5c9
AS
2727/* Store the contents of FROMVAL into the location of TOVAL.
2728 Return a new value with the location of TOVAL and contents of
2729 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2730 floating-point or non-scalar types. */
14f9c5c9 2731
d2e4a39e
AS
2732static struct value *
2733ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2734{
df407dfe
AC
2735 struct type *type = value_type (toval);
2736 int bits = value_bitsize (toval);
14f9c5c9 2737
52ce6436
PH
2738 toval = ada_coerce_ref (toval);
2739 fromval = ada_coerce_ref (fromval);
2740
2741 if (ada_is_direct_array_type (value_type (toval)))
2742 toval = ada_coerce_to_simple_array (toval);
2743 if (ada_is_direct_array_type (value_type (fromval)))
2744 fromval = ada_coerce_to_simple_array (fromval);
2745
88e3b34b 2746 if (!deprecated_value_modifiable (toval))
323e0a4a 2747 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2748
d2e4a39e 2749 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2750 && bits > 0
d2e4a39e 2751 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2752 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2753 {
df407dfe
AC
2754 int len = (value_bitpos (toval)
2755 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2756 int from_size;
224c3ddb 2757 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2758 struct value *val;
42ae5230 2759 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2760
2761 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2762 fromval = value_cast (type, fromval);
14f9c5c9 2763
52ce6436 2764 read_memory (to_addr, buffer, len);
aced2898
PH
2765 from_size = value_bitsize (fromval);
2766 if (from_size == 0)
2767 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2768 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2769 move_bits (buffer, value_bitpos (toval),
50810684 2770 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2771 else
50810684
UW
2772 move_bits (buffer, value_bitpos (toval),
2773 value_contents (fromval), 0, bits, 0);
972daa01 2774 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2775
14f9c5c9 2776 val = value_copy (toval);
0fd88904 2777 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2778 TYPE_LENGTH (type));
04624583 2779 deprecated_set_value_type (val, type);
d2e4a39e 2780
14f9c5c9
AS
2781 return val;
2782 }
2783
2784 return value_assign (toval, fromval);
2785}
2786
2787
7c512744
JB
2788/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2789 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2790 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2791 COMPONENT, and not the inferior's memory. The current contents
2792 of COMPONENT are ignored.
2793
2794 Although not part of the initial design, this function also works
2795 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2796 had a null address, and COMPONENT had an address which is equal to
2797 its offset inside CONTAINER. */
2798
52ce6436
PH
2799static void
2800value_assign_to_component (struct value *container, struct value *component,
2801 struct value *val)
2802{
2803 LONGEST offset_in_container =
42ae5230 2804 (LONGEST) (value_address (component) - value_address (container));
7c512744 2805 int bit_offset_in_container =
52ce6436
PH
2806 value_bitpos (component) - value_bitpos (container);
2807 int bits;
7c512744 2808
52ce6436
PH
2809 val = value_cast (value_type (component), val);
2810
2811 if (value_bitsize (component) == 0)
2812 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2813 else
2814 bits = value_bitsize (component);
2815
50810684 2816 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
7c512744 2817 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436
PH
2818 value_bitpos (container) + bit_offset_in_container,
2819 value_contents (val),
2820 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2821 bits, 1);
52ce6436 2822 else
7c512744 2823 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2824 value_bitpos (container) + bit_offset_in_container,
50810684 2825 value_contents (val), 0, bits, 0);
7c512744
JB
2826}
2827
4c4b4cd2
PH
2828/* The value of the element of array ARR at the ARITY indices given in IND.
2829 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2830 thereto. */
2831
d2e4a39e
AS
2832struct value *
2833ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2834{
2835 int k;
d2e4a39e
AS
2836 struct value *elt;
2837 struct type *elt_type;
14f9c5c9
AS
2838
2839 elt = ada_coerce_to_simple_array (arr);
2840
df407dfe 2841 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2842 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2843 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2844 return value_subscript_packed (elt, arity, ind);
2845
2846 for (k = 0; k < arity; k += 1)
2847 {
2848 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2849 error (_("too many subscripts (%d expected)"), k);
2497b498 2850 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2851 }
2852 return elt;
2853}
2854
deede10c
JB
2855/* Assuming ARR is a pointer to a GDB array, the value of the element
2856 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2857 Does not read the entire array into memory.
2858
2859 Note: Unlike what one would expect, this function is used instead of
2860 ada_value_subscript for basically all non-packed array types. The reason
2861 for this is that a side effect of doing our own pointer arithmetics instead
2862 of relying on value_subscript is that there is no implicit typedef peeling.
2863 This is important for arrays of array accesses, where it allows us to
2864 preserve the fact that the array's element is an array access, where the
2865 access part os encoded in a typedef layer. */
14f9c5c9 2866
2c0b251b 2867static struct value *
deede10c 2868ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2869{
2870 int k;
919e6dbe 2871 struct value *array_ind = ada_value_ind (arr);
deede10c 2872 struct type *type
919e6dbe
PMR
2873 = check_typedef (value_enclosing_type (array_ind));
2874
2875 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2876 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2877 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2878
2879 for (k = 0; k < arity; k += 1)
2880 {
2881 LONGEST lwb, upb;
aa715135 2882 struct value *lwb_value;
14f9c5c9
AS
2883
2884 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2885 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2886 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2887 value_copy (arr));
14f9c5c9 2888 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2889 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2890 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2891 type = TYPE_TARGET_TYPE (type);
2892 }
2893
2894 return value_ind (arr);
2895}
2896
0b5d8877 2897/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2898 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2899 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2900 this array is LOW, as per Ada rules. */
0b5d8877 2901static struct value *
f5938064
JG
2902ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2903 int low, int high)
0b5d8877 2904{
b0dd7688 2905 struct type *type0 = ada_check_typedef (type);
aa715135 2906 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2907 struct type *index_type
aa715135 2908 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2909 struct type *slice_type = create_array_type_with_stride
2910 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2911 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2912 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2913 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2914 LONGEST base_low_pos, low_pos;
2915 CORE_ADDR base;
2916
2917 if (!discrete_position (base_index_type, low, &low_pos)
2918 || !discrete_position (base_index_type, base_low, &base_low_pos))
2919 {
2920 warning (_("unable to get positions in slice, use bounds instead"));
2921 low_pos = low;
2922 base_low_pos = base_low;
2923 }
5b4ee69b 2924
aa715135
JG
2925 base = value_as_address (array_ptr)
2926 + ((low_pos - base_low_pos)
2927 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2928 return value_at_lazy (slice_type, base);
0b5d8877
PH
2929}
2930
2931
2932static struct value *
2933ada_value_slice (struct value *array, int low, int high)
2934{
b0dd7688 2935 struct type *type = ada_check_typedef (value_type (array));
aa715135 2936 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2937 struct type *index_type
2938 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2939 struct type *slice_type = create_array_type_with_stride
2940 (NULL, TYPE_TARGET_TYPE (type), index_type,
2941 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2942 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2943 LONGEST low_pos, high_pos;
5b4ee69b 2944
aa715135
JG
2945 if (!discrete_position (base_index_type, low, &low_pos)
2946 || !discrete_position (base_index_type, high, &high_pos))
2947 {
2948 warning (_("unable to get positions in slice, use bounds instead"));
2949 low_pos = low;
2950 high_pos = high;
2951 }
2952
2953 return value_cast (slice_type,
2954 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2955}
2956
14f9c5c9
AS
2957/* If type is a record type in the form of a standard GNAT array
2958 descriptor, returns the number of dimensions for type. If arr is a
2959 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2960 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2961
2962int
d2e4a39e 2963ada_array_arity (struct type *type)
14f9c5c9
AS
2964{
2965 int arity;
2966
2967 if (type == NULL)
2968 return 0;
2969
2970 type = desc_base_type (type);
2971
2972 arity = 0;
d2e4a39e 2973 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2974 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2975 else
2976 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2977 {
4c4b4cd2 2978 arity += 1;
61ee279c 2979 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2980 }
d2e4a39e 2981
14f9c5c9
AS
2982 return arity;
2983}
2984
2985/* If TYPE is a record type in the form of a standard GNAT array
2986 descriptor or a simple array type, returns the element type for
2987 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2988 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2989
d2e4a39e
AS
2990struct type *
2991ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2992{
2993 type = desc_base_type (type);
2994
d2e4a39e 2995 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2996 {
2997 int k;
d2e4a39e 2998 struct type *p_array_type;
14f9c5c9 2999
556bdfd4 3000 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
3001
3002 k = ada_array_arity (type);
3003 if (k == 0)
4c4b4cd2 3004 return NULL;
d2e4a39e 3005
4c4b4cd2 3006 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 3007 if (nindices >= 0 && k > nindices)
4c4b4cd2 3008 k = nindices;
d2e4a39e 3009 while (k > 0 && p_array_type != NULL)
4c4b4cd2 3010 {
61ee279c 3011 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
3012 k -= 1;
3013 }
14f9c5c9
AS
3014 return p_array_type;
3015 }
3016 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3017 {
3018 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3019 {
3020 type = TYPE_TARGET_TYPE (type);
3021 nindices -= 1;
3022 }
14f9c5c9
AS
3023 return type;
3024 }
3025
3026 return NULL;
3027}
3028
4c4b4cd2 3029/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3030 Does not examine memory. Throws an error if N is invalid or TYPE
3031 is not an array type. NAME is the name of the Ada attribute being
3032 evaluated ('range, 'first, 'last, or 'length); it is used in building
3033 the error message. */
14f9c5c9 3034
1eea4ebd
UW
3035static struct type *
3036ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3037{
4c4b4cd2
PH
3038 struct type *result_type;
3039
14f9c5c9
AS
3040 type = desc_base_type (type);
3041
1eea4ebd
UW
3042 if (n < 0 || n > ada_array_arity (type))
3043 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3044
4c4b4cd2 3045 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3046 {
3047 int i;
3048
3049 for (i = 1; i < n; i += 1)
4c4b4cd2 3050 type = TYPE_TARGET_TYPE (type);
262452ec 3051 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3052 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3053 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3054 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3055 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3056 result_type = NULL;
14f9c5c9 3057 }
d2e4a39e 3058 else
1eea4ebd
UW
3059 {
3060 result_type = desc_index_type (desc_bounds_type (type), n);
3061 if (result_type == NULL)
3062 error (_("attempt to take bound of something that is not an array"));
3063 }
3064
3065 return result_type;
14f9c5c9
AS
3066}
3067
3068/* Given that arr is an array type, returns the lower bound of the
3069 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3070 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3071 array-descriptor type. It works for other arrays with bounds supplied
3072 by run-time quantities other than discriminants. */
14f9c5c9 3073
abb68b3e 3074static LONGEST
fb5e3d5c 3075ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3076{
8a48ac95 3077 struct type *type, *index_type_desc, *index_type;
1ce677a4 3078 int i;
262452ec
JK
3079
3080 gdb_assert (which == 0 || which == 1);
14f9c5c9 3081
ad82864c
JB
3082 if (ada_is_constrained_packed_array_type (arr_type))
3083 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3084
4c4b4cd2 3085 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3086 return (LONGEST) - which;
14f9c5c9
AS
3087
3088 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3089 type = TYPE_TARGET_TYPE (arr_type);
3090 else
3091 type = arr_type;
3092
bafffb51
JB
3093 if (TYPE_FIXED_INSTANCE (type))
3094 {
3095 /* The array has already been fixed, so we do not need to
3096 check the parallel ___XA type again. That encoding has
3097 already been applied, so ignore it now. */
3098 index_type_desc = NULL;
3099 }
3100 else
3101 {
3102 index_type_desc = ada_find_parallel_type (type, "___XA");
3103 ada_fixup_array_indexes_type (index_type_desc);
3104 }
3105
262452ec 3106 if (index_type_desc != NULL)
28c85d6c
JB
3107 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3108 NULL);
262452ec 3109 else
8a48ac95
JB
3110 {
3111 struct type *elt_type = check_typedef (type);
3112
3113 for (i = 1; i < n; i++)
3114 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3115
3116 index_type = TYPE_INDEX_TYPE (elt_type);
3117 }
262452ec 3118
43bbcdc2
PH
3119 return
3120 (LONGEST) (which == 0
3121 ? ada_discrete_type_low_bound (index_type)
3122 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3123}
3124
3125/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3126 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3127 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3128 supplied by run-time quantities other than discriminants. */
14f9c5c9 3129
1eea4ebd 3130static LONGEST
4dc81987 3131ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3132{
eb479039
JB
3133 struct type *arr_type;
3134
3135 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3136 arr = value_ind (arr);
3137 arr_type = value_enclosing_type (arr);
14f9c5c9 3138
ad82864c
JB
3139 if (ada_is_constrained_packed_array_type (arr_type))
3140 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3141 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3142 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3143 else
1eea4ebd 3144 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3145}
3146
3147/* Given that arr is an array value, returns the length of the
3148 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3149 supplied by run-time quantities other than discriminants.
3150 Does not work for arrays indexed by enumeration types with representation
3151 clauses at the moment. */
14f9c5c9 3152
1eea4ebd 3153static LONGEST
d2e4a39e 3154ada_array_length (struct value *arr, int n)
14f9c5c9 3155{
aa715135
JG
3156 struct type *arr_type, *index_type;
3157 int low, high;
eb479039
JB
3158
3159 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3160 arr = value_ind (arr);
3161 arr_type = value_enclosing_type (arr);
14f9c5c9 3162
ad82864c
JB
3163 if (ada_is_constrained_packed_array_type (arr_type))
3164 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3165
4c4b4cd2 3166 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3167 {
3168 low = ada_array_bound_from_type (arr_type, n, 0);
3169 high = ada_array_bound_from_type (arr_type, n, 1);
3170 }
14f9c5c9 3171 else
aa715135
JG
3172 {
3173 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3174 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3175 }
3176
f168693b 3177 arr_type = check_typedef (arr_type);
7150d33c 3178 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3179 if (index_type != NULL)
3180 {
3181 struct type *base_type;
3182 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3183 base_type = TYPE_TARGET_TYPE (index_type);
3184 else
3185 base_type = index_type;
3186
3187 low = pos_atr (value_from_longest (base_type, low));
3188 high = pos_atr (value_from_longest (base_type, high));
3189 }
3190 return high - low + 1;
4c4b4cd2
PH
3191}
3192
3193/* An empty array whose type is that of ARR_TYPE (an array type),
3194 with bounds LOW to LOW-1. */
3195
3196static struct value *
3197empty_array (struct type *arr_type, int low)
3198{
b0dd7688 3199 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3200 struct type *index_type
3201 = create_static_range_type
3202 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3203 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3204
0b5d8877 3205 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3206}
14f9c5c9 3207\f
d2e4a39e 3208
4c4b4cd2 3209 /* Name resolution */
14f9c5c9 3210
4c4b4cd2
PH
3211/* The "decoded" name for the user-definable Ada operator corresponding
3212 to OP. */
14f9c5c9 3213
d2e4a39e 3214static const char *
4c4b4cd2 3215ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3216{
3217 int i;
3218
4c4b4cd2 3219 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3220 {
3221 if (ada_opname_table[i].op == op)
4c4b4cd2 3222 return ada_opname_table[i].decoded;
14f9c5c9 3223 }
323e0a4a 3224 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3225}
3226
3227
4c4b4cd2
PH
3228/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3229 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3230 undefined namespace) and converts operators that are
3231 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3232 non-null, it provides a preferred result type [at the moment, only
3233 type void has any effect---causing procedures to be preferred over
3234 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3235 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3236
4c4b4cd2 3237static void
e9d9f57e 3238resolve (expression_up *expp, int void_context_p)
14f9c5c9 3239{
30b15541
UW
3240 struct type *context_type = NULL;
3241 int pc = 0;
3242
3243 if (void_context_p)
3244 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3245
3246 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3247}
3248
4c4b4cd2
PH
3249/* Resolve the operator of the subexpression beginning at
3250 position *POS of *EXPP. "Resolving" consists of replacing
3251 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3252 with their resolutions, replacing built-in operators with
3253 function calls to user-defined operators, where appropriate, and,
3254 when DEPROCEDURE_P is non-zero, converting function-valued variables
3255 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3256 are as in ada_resolve, above. */
14f9c5c9 3257
d2e4a39e 3258static struct value *
e9d9f57e 3259resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
76a01679 3260 struct type *context_type)
14f9c5c9
AS
3261{
3262 int pc = *pos;
3263 int i;
4c4b4cd2 3264 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3265 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3266 struct value **argvec; /* Vector of operand types (alloca'ed). */
3267 int nargs; /* Number of operands. */
52ce6436 3268 int oplen;
ec6a20c2 3269 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
14f9c5c9
AS
3270
3271 argvec = NULL;
3272 nargs = 0;
e9d9f57e 3273 exp = expp->get ();
14f9c5c9 3274
52ce6436
PH
3275 /* Pass one: resolve operands, saving their types and updating *pos,
3276 if needed. */
14f9c5c9
AS
3277 switch (op)
3278 {
4c4b4cd2
PH
3279 case OP_FUNCALL:
3280 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3281 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3282 *pos += 7;
4c4b4cd2
PH
3283 else
3284 {
3285 *pos += 3;
3286 resolve_subexp (expp, pos, 0, NULL);
3287 }
3288 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3289 break;
3290
14f9c5c9 3291 case UNOP_ADDR:
4c4b4cd2
PH
3292 *pos += 1;
3293 resolve_subexp (expp, pos, 0, NULL);
3294 break;
3295
52ce6436
PH
3296 case UNOP_QUAL:
3297 *pos += 3;
17466c1a 3298 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3299 break;
3300
52ce6436 3301 case OP_ATR_MODULUS:
4c4b4cd2
PH
3302 case OP_ATR_SIZE:
3303 case OP_ATR_TAG:
4c4b4cd2
PH
3304 case OP_ATR_FIRST:
3305 case OP_ATR_LAST:
3306 case OP_ATR_LENGTH:
3307 case OP_ATR_POS:
3308 case OP_ATR_VAL:
4c4b4cd2
PH
3309 case OP_ATR_MIN:
3310 case OP_ATR_MAX:
52ce6436
PH
3311 case TERNOP_IN_RANGE:
3312 case BINOP_IN_BOUNDS:
3313 case UNOP_IN_RANGE:
3314 case OP_AGGREGATE:
3315 case OP_OTHERS:
3316 case OP_CHOICES:
3317 case OP_POSITIONAL:
3318 case OP_DISCRETE_RANGE:
3319 case OP_NAME:
3320 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3321 *pos += oplen;
14f9c5c9
AS
3322 break;
3323
3324 case BINOP_ASSIGN:
3325 {
4c4b4cd2
PH
3326 struct value *arg1;
3327
3328 *pos += 1;
3329 arg1 = resolve_subexp (expp, pos, 0, NULL);
3330 if (arg1 == NULL)
3331 resolve_subexp (expp, pos, 1, NULL);
3332 else
df407dfe 3333 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3334 break;
14f9c5c9
AS
3335 }
3336
4c4b4cd2 3337 case UNOP_CAST:
4c4b4cd2
PH
3338 *pos += 3;
3339 nargs = 1;
3340 break;
14f9c5c9 3341
4c4b4cd2
PH
3342 case BINOP_ADD:
3343 case BINOP_SUB:
3344 case BINOP_MUL:
3345 case BINOP_DIV:
3346 case BINOP_REM:
3347 case BINOP_MOD:
3348 case BINOP_EXP:
3349 case BINOP_CONCAT:
3350 case BINOP_LOGICAL_AND:
3351 case BINOP_LOGICAL_OR:
3352 case BINOP_BITWISE_AND:
3353 case BINOP_BITWISE_IOR:
3354 case BINOP_BITWISE_XOR:
14f9c5c9 3355
4c4b4cd2
PH
3356 case BINOP_EQUAL:
3357 case BINOP_NOTEQUAL:
3358 case BINOP_LESS:
3359 case BINOP_GTR:
3360 case BINOP_LEQ:
3361 case BINOP_GEQ:
14f9c5c9 3362
4c4b4cd2
PH
3363 case BINOP_REPEAT:
3364 case BINOP_SUBSCRIPT:
3365 case BINOP_COMMA:
40c8aaa9
JB
3366 *pos += 1;
3367 nargs = 2;
3368 break;
14f9c5c9 3369
4c4b4cd2
PH
3370 case UNOP_NEG:
3371 case UNOP_PLUS:
3372 case UNOP_LOGICAL_NOT:
3373 case UNOP_ABS:
3374 case UNOP_IND:
3375 *pos += 1;
3376 nargs = 1;
3377 break;
14f9c5c9 3378
4c4b4cd2 3379 case OP_LONG:
edd079d9 3380 case OP_FLOAT:
4c4b4cd2 3381 case OP_VAR_VALUE:
74ea4be4 3382 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3383 *pos += 4;
3384 break;
14f9c5c9 3385
4c4b4cd2
PH
3386 case OP_TYPE:
3387 case OP_BOOL:
3388 case OP_LAST:
4c4b4cd2
PH
3389 case OP_INTERNALVAR:
3390 *pos += 3;
3391 break;
14f9c5c9 3392
4c4b4cd2
PH
3393 case UNOP_MEMVAL:
3394 *pos += 3;
3395 nargs = 1;
3396 break;
3397
67f3407f
DJ
3398 case OP_REGISTER:
3399 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3400 break;
3401
4c4b4cd2
PH
3402 case STRUCTOP_STRUCT:
3403 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3404 nargs = 1;
3405 break;
3406
4c4b4cd2 3407 case TERNOP_SLICE:
4c4b4cd2
PH
3408 *pos += 1;
3409 nargs = 3;
3410 break;
3411
52ce6436 3412 case OP_STRING:
14f9c5c9 3413 break;
4c4b4cd2
PH
3414
3415 default:
323e0a4a 3416 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3417 }
3418
8d749320 3419 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2
PH
3420 for (i = 0; i < nargs; i += 1)
3421 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3422 argvec[i] = NULL;
e9d9f57e 3423 exp = expp->get ();
4c4b4cd2
PH
3424
3425 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3426 switch (op)
3427 {
3428 default:
3429 break;
3430
14f9c5c9 3431 case OP_VAR_VALUE:
4c4b4cd2 3432 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3433 {
d12307c1 3434 struct block_symbol *candidates;
76a01679
JB
3435 int n_candidates;
3436
3437 n_candidates =
3438 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3439 (exp->elts[pc + 2].symbol),
3440 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3441 &candidates);
ec6a20c2 3442 make_cleanup (xfree, candidates);
76a01679
JB
3443
3444 if (n_candidates > 1)
3445 {
3446 /* Types tend to get re-introduced locally, so if there
3447 are any local symbols that are not types, first filter
3448 out all types. */
3449 int j;
3450 for (j = 0; j < n_candidates; j += 1)
d12307c1 3451 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3452 {
3453 case LOC_REGISTER:
3454 case LOC_ARG:
3455 case LOC_REF_ARG:
76a01679
JB
3456 case LOC_REGPARM_ADDR:
3457 case LOC_LOCAL:
76a01679 3458 case LOC_COMPUTED:
76a01679
JB
3459 goto FoundNonType;
3460 default:
3461 break;
3462 }
3463 FoundNonType:
3464 if (j < n_candidates)
3465 {
3466 j = 0;
3467 while (j < n_candidates)
3468 {
d12307c1 3469 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3470 {
3471 candidates[j] = candidates[n_candidates - 1];
3472 n_candidates -= 1;
3473 }
3474 else
3475 j += 1;
3476 }
3477 }
3478 }
3479
3480 if (n_candidates == 0)
323e0a4a 3481 error (_("No definition found for %s"),
76a01679
JB
3482 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3483 else if (n_candidates == 1)
3484 i = 0;
3485 else if (deprocedure_p
3486 && !is_nonfunction (candidates, n_candidates))
3487 {
06d5cf63
JB
3488 i = ada_resolve_function
3489 (candidates, n_candidates, NULL, 0,
3490 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3491 context_type);
76a01679 3492 if (i < 0)
323e0a4a 3493 error (_("Could not find a match for %s"),
76a01679
JB
3494 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3495 }
3496 else
3497 {
323e0a4a 3498 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3499 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3500 user_select_syms (candidates, n_candidates, 1);
3501 i = 0;
3502 }
3503
3504 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3505 exp->elts[pc + 2].symbol = candidates[i].symbol;
aee1fcdf 3506 innermost_block.update (candidates[i]);
76a01679
JB
3507 }
3508
3509 if (deprocedure_p
3510 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3511 == TYPE_CODE_FUNC))
3512 {
3513 replace_operator_with_call (expp, pc, 0, 0,
3514 exp->elts[pc + 2].symbol,
3515 exp->elts[pc + 1].block);
e9d9f57e 3516 exp = expp->get ();
76a01679 3517 }
14f9c5c9
AS
3518 break;
3519
3520 case OP_FUNCALL:
3521 {
4c4b4cd2 3522 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3523 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3524 {
d12307c1 3525 struct block_symbol *candidates;
4c4b4cd2
PH
3526 int n_candidates;
3527
3528 n_candidates =
76a01679
JB
3529 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3530 (exp->elts[pc + 5].symbol),
3531 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3532 &candidates);
ec6a20c2
JB
3533 make_cleanup (xfree, candidates);
3534
4c4b4cd2
PH
3535 if (n_candidates == 1)
3536 i = 0;
3537 else
3538 {
06d5cf63
JB
3539 i = ada_resolve_function
3540 (candidates, n_candidates,
3541 argvec, nargs,
3542 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3543 context_type);
4c4b4cd2 3544 if (i < 0)
323e0a4a 3545 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3546 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3547 }
3548
3549 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3550 exp->elts[pc + 5].symbol = candidates[i].symbol;
aee1fcdf 3551 innermost_block.update (candidates[i]);
4c4b4cd2 3552 }
14f9c5c9
AS
3553 }
3554 break;
3555 case BINOP_ADD:
3556 case BINOP_SUB:
3557 case BINOP_MUL:
3558 case BINOP_DIV:
3559 case BINOP_REM:
3560 case BINOP_MOD:
3561 case BINOP_CONCAT:
3562 case BINOP_BITWISE_AND:
3563 case BINOP_BITWISE_IOR:
3564 case BINOP_BITWISE_XOR:
3565 case BINOP_EQUAL:
3566 case BINOP_NOTEQUAL:
3567 case BINOP_LESS:
3568 case BINOP_GTR:
3569 case BINOP_LEQ:
3570 case BINOP_GEQ:
3571 case BINOP_EXP:
3572 case UNOP_NEG:
3573 case UNOP_PLUS:
3574 case UNOP_LOGICAL_NOT:
3575 case UNOP_ABS:
3576 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3577 {
d12307c1 3578 struct block_symbol *candidates;
4c4b4cd2
PH
3579 int n_candidates;
3580
3581 n_candidates =
b5ec771e 3582 ada_lookup_symbol_list (ada_decoded_op_name (op),
4c4b4cd2 3583 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3584 &candidates);
ec6a20c2
JB
3585 make_cleanup (xfree, candidates);
3586
4c4b4cd2 3587 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3588 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3589 if (i < 0)
3590 break;
3591
d12307c1
PMR
3592 replace_operator_with_call (expp, pc, nargs, 1,
3593 candidates[i].symbol,
3594 candidates[i].block);
e9d9f57e 3595 exp = expp->get ();
4c4b4cd2 3596 }
14f9c5c9 3597 break;
4c4b4cd2
PH
3598
3599 case OP_TYPE:
b3dbf008 3600 case OP_REGISTER:
ec6a20c2 3601 do_cleanups (old_chain);
4c4b4cd2 3602 return NULL;
14f9c5c9
AS
3603 }
3604
3605 *pos = pc;
ec6a20c2 3606 do_cleanups (old_chain);
ced9779b
JB
3607 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3608 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3609 exp->elts[pc + 1].objfile,
3610 exp->elts[pc + 2].msymbol);
3611 else
3612 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3613}
3614
3615/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3616 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3617 a non-pointer. */
14f9c5c9 3618/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3619 liberal. */
14f9c5c9
AS
3620
3621static int
4dc81987 3622ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3623{
61ee279c
PH
3624 ftype = ada_check_typedef (ftype);
3625 atype = ada_check_typedef (atype);
14f9c5c9
AS
3626
3627 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3628 ftype = TYPE_TARGET_TYPE (ftype);
3629 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3630 atype = TYPE_TARGET_TYPE (atype);
3631
d2e4a39e 3632 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3633 {
3634 default:
5b3d5b7d 3635 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3636 case TYPE_CODE_PTR:
3637 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3638 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3639 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3640 else
1265e4aa
JB
3641 return (may_deref
3642 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3643 case TYPE_CODE_INT:
3644 case TYPE_CODE_ENUM:
3645 case TYPE_CODE_RANGE:
3646 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3647 {
3648 case TYPE_CODE_INT:
3649 case TYPE_CODE_ENUM:
3650 case TYPE_CODE_RANGE:
3651 return 1;
3652 default:
3653 return 0;
3654 }
14f9c5c9
AS
3655
3656 case TYPE_CODE_ARRAY:
d2e4a39e 3657 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3658 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3659
3660 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3661 if (ada_is_array_descriptor_type (ftype))
3662 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3663 || ada_is_array_descriptor_type (atype));
14f9c5c9 3664 else
4c4b4cd2
PH
3665 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3666 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3667
3668 case TYPE_CODE_UNION:
3669 case TYPE_CODE_FLT:
3670 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3671 }
3672}
3673
3674/* Return non-zero if the formals of FUNC "sufficiently match" the
3675 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3676 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3677 argument function. */
14f9c5c9
AS
3678
3679static int
d2e4a39e 3680ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3681{
3682 int i;
d2e4a39e 3683 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3684
1265e4aa
JB
3685 if (SYMBOL_CLASS (func) == LOC_CONST
3686 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3687 return (n_actuals == 0);
3688 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3689 return 0;
3690
3691 if (TYPE_NFIELDS (func_type) != n_actuals)
3692 return 0;
3693
3694 for (i = 0; i < n_actuals; i += 1)
3695 {
4c4b4cd2 3696 if (actuals[i] == NULL)
76a01679
JB
3697 return 0;
3698 else
3699 {
5b4ee69b
MS
3700 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3701 i));
df407dfe 3702 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3703
76a01679
JB
3704 if (!ada_type_match (ftype, atype, 1))
3705 return 0;
3706 }
14f9c5c9
AS
3707 }
3708 return 1;
3709}
3710
3711/* False iff function type FUNC_TYPE definitely does not produce a value
3712 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3713 FUNC_TYPE is not a valid function type with a non-null return type
3714 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3715
3716static int
d2e4a39e 3717return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3718{
d2e4a39e 3719 struct type *return_type;
14f9c5c9
AS
3720
3721 if (func_type == NULL)
3722 return 1;
3723
4c4b4cd2 3724 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3725 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3726 else
18af8284 3727 return_type = get_base_type (func_type);
14f9c5c9
AS
3728 if (return_type == NULL)
3729 return 1;
3730
18af8284 3731 context_type = get_base_type (context_type);
14f9c5c9
AS
3732
3733 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3734 return context_type == NULL || return_type == context_type;
3735 else if (context_type == NULL)
3736 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3737 else
3738 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3739}
3740
3741
4c4b4cd2 3742/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3743 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3744 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3745 that returns that type, then eliminate matches that don't. If
3746 CONTEXT_TYPE is void and there is at least one match that does not
3747 return void, eliminate all matches that do.
3748
14f9c5c9
AS
3749 Asks the user if there is more than one match remaining. Returns -1
3750 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3751 solely for messages. May re-arrange and modify SYMS in
3752 the process; the index returned is for the modified vector. */
14f9c5c9 3753
4c4b4cd2 3754static int
d12307c1 3755ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3756 int nsyms, struct value **args, int nargs,
3757 const char *name, struct type *context_type)
14f9c5c9 3758{
30b15541 3759 int fallback;
14f9c5c9 3760 int k;
4c4b4cd2 3761 int m; /* Number of hits */
14f9c5c9 3762
d2e4a39e 3763 m = 0;
30b15541
UW
3764 /* In the first pass of the loop, we only accept functions matching
3765 context_type. If none are found, we add a second pass of the loop
3766 where every function is accepted. */
3767 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3768 {
3769 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3770 {
d12307c1 3771 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3772
d12307c1 3773 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3774 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3775 {
3776 syms[m] = syms[k];
3777 m += 1;
3778 }
3779 }
14f9c5c9
AS
3780 }
3781
dc5c8746
PMR
3782 /* If we got multiple matches, ask the user which one to use. Don't do this
3783 interactive thing during completion, though, as the purpose of the
3784 completion is providing a list of all possible matches. Prompting the
3785 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3786 if (m == 0)
3787 return -1;
dc5c8746 3788 else if (m > 1 && !parse_completion)
14f9c5c9 3789 {
323e0a4a 3790 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3791 user_select_syms (syms, m, 1);
14f9c5c9
AS
3792 return 0;
3793 }
3794 return 0;
3795}
3796
4c4b4cd2
PH
3797/* Returns true (non-zero) iff decoded name N0 should appear before N1
3798 in a listing of choices during disambiguation (see sort_choices, below).
3799 The idea is that overloadings of a subprogram name from the
3800 same package should sort in their source order. We settle for ordering
3801 such symbols by their trailing number (__N or $N). */
3802
14f9c5c9 3803static int
0d5cff50 3804encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3805{
3806 if (N1 == NULL)
3807 return 0;
3808 else if (N0 == NULL)
3809 return 1;
3810 else
3811 {
3812 int k0, k1;
5b4ee69b 3813
d2e4a39e 3814 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3815 ;
d2e4a39e 3816 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3817 ;
d2e4a39e 3818 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3819 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3820 {
3821 int n0, n1;
5b4ee69b 3822
4c4b4cd2
PH
3823 n0 = k0;
3824 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3825 n0 -= 1;
3826 n1 = k1;
3827 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3828 n1 -= 1;
3829 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3830 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3831 }
14f9c5c9
AS
3832 return (strcmp (N0, N1) < 0);
3833 }
3834}
d2e4a39e 3835
4c4b4cd2
PH
3836/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3837 encoded names. */
3838
d2e4a39e 3839static void
d12307c1 3840sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3841{
4c4b4cd2 3842 int i;
5b4ee69b 3843
d2e4a39e 3844 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3845 {
d12307c1 3846 struct block_symbol sym = syms[i];
14f9c5c9
AS
3847 int j;
3848
d2e4a39e 3849 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3850 {
d12307c1
PMR
3851 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3852 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3853 break;
3854 syms[j + 1] = syms[j];
3855 }
d2e4a39e 3856 syms[j + 1] = sym;
14f9c5c9
AS
3857 }
3858}
3859
d72413e6
PMR
3860/* Whether GDB should display formals and return types for functions in the
3861 overloads selection menu. */
3862static int print_signatures = 1;
3863
3864/* Print the signature for SYM on STREAM according to the FLAGS options. For
3865 all but functions, the signature is just the name of the symbol. For
3866 functions, this is the name of the function, the list of types for formals
3867 and the return type (if any). */
3868
3869static void
3870ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3871 const struct type_print_options *flags)
3872{
3873 struct type *type = SYMBOL_TYPE (sym);
3874
3875 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3876 if (!print_signatures
3877 || type == NULL
3878 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3879 return;
3880
3881 if (TYPE_NFIELDS (type) > 0)
3882 {
3883 int i;
3884
3885 fprintf_filtered (stream, " (");
3886 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3887 {
3888 if (i > 0)
3889 fprintf_filtered (stream, "; ");
3890 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3891 flags);
3892 }
3893 fprintf_filtered (stream, ")");
3894 }
3895 if (TYPE_TARGET_TYPE (type) != NULL
3896 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3897 {
3898 fprintf_filtered (stream, " return ");
3899 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3900 }
3901}
3902
4c4b4cd2
PH
3903/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3904 by asking the user (if necessary), returning the number selected,
3905 and setting the first elements of SYMS items. Error if no symbols
3906 selected. */
14f9c5c9
AS
3907
3908/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3909 to be re-integrated one of these days. */
14f9c5c9
AS
3910
3911int
d12307c1 3912user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3913{
3914 int i;
8d749320 3915 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3916 int n_chosen;
3917 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3918 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3919
3920 if (max_results < 1)
323e0a4a 3921 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3922 if (nsyms <= 1)
3923 return nsyms;
3924
717d2f5a
JB
3925 if (select_mode == multiple_symbols_cancel)
3926 error (_("\
3927canceled because the command is ambiguous\n\
3928See set/show multiple-symbol."));
3929
3930 /* If select_mode is "all", then return all possible symbols.
3931 Only do that if more than one symbol can be selected, of course.
3932 Otherwise, display the menu as usual. */
3933 if (select_mode == multiple_symbols_all && max_results > 1)
3934 return nsyms;
3935
323e0a4a 3936 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3937 if (max_results > 1)
323e0a4a 3938 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3939
4c4b4cd2 3940 sort_choices (syms, nsyms);
14f9c5c9
AS
3941
3942 for (i = 0; i < nsyms; i += 1)
3943 {
d12307c1 3944 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3945 continue;
3946
d12307c1 3947 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3948 {
76a01679 3949 struct symtab_and_line sal =
d12307c1 3950 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3951
d72413e6
PMR
3952 printf_unfiltered ("[%d] ", i + first_choice);
3953 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3954 &type_print_raw_options);
323e0a4a 3955 if (sal.symtab == NULL)
d72413e6 3956 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3957 sal.line);
3958 else
d72413e6 3959 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3960 symtab_to_filename_for_display (sal.symtab),
3961 sal.line);
4c4b4cd2
PH
3962 continue;
3963 }
d2e4a39e 3964 else
4c4b4cd2
PH
3965 {
3966 int is_enumeral =
d12307c1
PMR
3967 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3968 && SYMBOL_TYPE (syms[i].symbol) != NULL
3969 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3970 struct symtab *symtab = NULL;
3971
d12307c1
PMR
3972 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3973 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3974
d12307c1 3975 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3976 {
3977 printf_unfiltered ("[%d] ", i + first_choice);
3978 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3979 &type_print_raw_options);
3980 printf_unfiltered (_(" at %s:%d\n"),
3981 symtab_to_filename_for_display (symtab),
3982 SYMBOL_LINE (syms[i].symbol));
3983 }
76a01679 3984 else if (is_enumeral
d12307c1 3985 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3986 {
a3f17187 3987 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3988 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3989 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3990 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3991 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3992 }
d72413e6
PMR
3993 else
3994 {
3995 printf_unfiltered ("[%d] ", i + first_choice);
3996 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3997 &type_print_raw_options);
3998
3999 if (symtab != NULL)
4000 printf_unfiltered (is_enumeral
4001 ? _(" in %s (enumeral)\n")
4002 : _(" at %s:?\n"),
4003 symtab_to_filename_for_display (symtab));
4004 else
4005 printf_unfiltered (is_enumeral
4006 ? _(" (enumeral)\n")
4007 : _(" at ?\n"));
4008 }
4c4b4cd2 4009 }
14f9c5c9 4010 }
d2e4a39e 4011
14f9c5c9 4012 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4013 "overload-choice");
14f9c5c9
AS
4014
4015 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4016 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4017
4018 return n_chosen;
4019}
4020
4021/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4022 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4023 order in CHOICES[0 .. N-1], and return N.
4024
4025 The user types choices as a sequence of numbers on one line
4026 separated by blanks, encoding them as follows:
4027
4c4b4cd2 4028 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4029 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4030 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4031
4c4b4cd2 4032 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4033
4034 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4035 prompts (for use with the -f switch). */
14f9c5c9
AS
4036
4037int
d2e4a39e 4038get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4039 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4040{
d2e4a39e 4041 char *args;
a121b7c1 4042 const char *prompt;
14f9c5c9
AS
4043 int n_chosen;
4044 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4045
14f9c5c9
AS
4046 prompt = getenv ("PS2");
4047 if (prompt == NULL)
0bcd0149 4048 prompt = "> ";
14f9c5c9 4049
0bcd0149 4050 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 4051
14f9c5c9 4052 if (args == NULL)
323e0a4a 4053 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4054
4055 n_chosen = 0;
76a01679 4056
4c4b4cd2
PH
4057 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4058 order, as given in args. Choices are validated. */
14f9c5c9
AS
4059 while (1)
4060 {
d2e4a39e 4061 char *args2;
14f9c5c9
AS
4062 int choice, j;
4063
0fcd72ba 4064 args = skip_spaces (args);
14f9c5c9 4065 if (*args == '\0' && n_chosen == 0)
323e0a4a 4066 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4067 else if (*args == '\0')
4c4b4cd2 4068 break;
14f9c5c9
AS
4069
4070 choice = strtol (args, &args2, 10);
d2e4a39e 4071 if (args == args2 || choice < 0
4c4b4cd2 4072 || choice > n_choices + first_choice - 1)
323e0a4a 4073 error (_("Argument must be choice number"));
14f9c5c9
AS
4074 args = args2;
4075
d2e4a39e 4076 if (choice == 0)
323e0a4a 4077 error (_("cancelled"));
14f9c5c9
AS
4078
4079 if (choice < first_choice)
4c4b4cd2
PH
4080 {
4081 n_chosen = n_choices;
4082 for (j = 0; j < n_choices; j += 1)
4083 choices[j] = j;
4084 break;
4085 }
14f9c5c9
AS
4086 choice -= first_choice;
4087
d2e4a39e 4088 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4089 {
4090 }
14f9c5c9
AS
4091
4092 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4093 {
4094 int k;
5b4ee69b 4095
4c4b4cd2
PH
4096 for (k = n_chosen - 1; k > j; k -= 1)
4097 choices[k + 1] = choices[k];
4098 choices[j + 1] = choice;
4099 n_chosen += 1;
4100 }
14f9c5c9
AS
4101 }
4102
4103 if (n_chosen > max_results)
323e0a4a 4104 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4105
14f9c5c9
AS
4106 return n_chosen;
4107}
4108
4c4b4cd2
PH
4109/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4110 on the function identified by SYM and BLOCK, and taking NARGS
4111 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4112
4113static void
e9d9f57e 4114replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4115 int oplen, struct symbol *sym,
270140bd 4116 const struct block *block)
14f9c5c9
AS
4117{
4118 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4119 symbol, -oplen for operator being replaced). */
d2e4a39e 4120 struct expression *newexp = (struct expression *)
8c1a34e7 4121 xzalloc (sizeof (struct expression)
4c4b4cd2 4122 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4123 struct expression *exp = expp->get ();
14f9c5c9
AS
4124
4125 newexp->nelts = exp->nelts + 7 - oplen;
4126 newexp->language_defn = exp->language_defn;
3489610d 4127 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4128 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4129 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4130 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4131
4132 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4133 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4134
4135 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4136 newexp->elts[pc + 4].block = block;
4137 newexp->elts[pc + 5].symbol = sym;
4138
e9d9f57e 4139 expp->reset (newexp);
d2e4a39e 4140}
14f9c5c9
AS
4141
4142/* Type-class predicates */
4143
4c4b4cd2
PH
4144/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4145 or FLOAT). */
14f9c5c9
AS
4146
4147static int
d2e4a39e 4148numeric_type_p (struct type *type)
14f9c5c9
AS
4149{
4150 if (type == NULL)
4151 return 0;
d2e4a39e
AS
4152 else
4153 {
4154 switch (TYPE_CODE (type))
4c4b4cd2
PH
4155 {
4156 case TYPE_CODE_INT:
4157 case TYPE_CODE_FLT:
4158 return 1;
4159 case TYPE_CODE_RANGE:
4160 return (type == TYPE_TARGET_TYPE (type)
4161 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4162 default:
4163 return 0;
4164 }
d2e4a39e 4165 }
14f9c5c9
AS
4166}
4167
4c4b4cd2 4168/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4169
4170static int
d2e4a39e 4171integer_type_p (struct type *type)
14f9c5c9
AS
4172{
4173 if (type == NULL)
4174 return 0;
d2e4a39e
AS
4175 else
4176 {
4177 switch (TYPE_CODE (type))
4c4b4cd2
PH
4178 {
4179 case TYPE_CODE_INT:
4180 return 1;
4181 case TYPE_CODE_RANGE:
4182 return (type == TYPE_TARGET_TYPE (type)
4183 || integer_type_p (TYPE_TARGET_TYPE (type)));
4184 default:
4185 return 0;
4186 }
d2e4a39e 4187 }
14f9c5c9
AS
4188}
4189
4c4b4cd2 4190/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4191
4192static int
d2e4a39e 4193scalar_type_p (struct type *type)
14f9c5c9
AS
4194{
4195 if (type == NULL)
4196 return 0;
d2e4a39e
AS
4197 else
4198 {
4199 switch (TYPE_CODE (type))
4c4b4cd2
PH
4200 {
4201 case TYPE_CODE_INT:
4202 case TYPE_CODE_RANGE:
4203 case TYPE_CODE_ENUM:
4204 case TYPE_CODE_FLT:
4205 return 1;
4206 default:
4207 return 0;
4208 }
d2e4a39e 4209 }
14f9c5c9
AS
4210}
4211
4c4b4cd2 4212/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4213
4214static int
d2e4a39e 4215discrete_type_p (struct type *type)
14f9c5c9
AS
4216{
4217 if (type == NULL)
4218 return 0;
d2e4a39e
AS
4219 else
4220 {
4221 switch (TYPE_CODE (type))
4c4b4cd2
PH
4222 {
4223 case TYPE_CODE_INT:
4224 case TYPE_CODE_RANGE:
4225 case TYPE_CODE_ENUM:
872f0337 4226 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4227 return 1;
4228 default:
4229 return 0;
4230 }
d2e4a39e 4231 }
14f9c5c9
AS
4232}
4233
4c4b4cd2
PH
4234/* Returns non-zero if OP with operands in the vector ARGS could be
4235 a user-defined function. Errs on the side of pre-defined operators
4236 (i.e., result 0). */
14f9c5c9
AS
4237
4238static int
d2e4a39e 4239possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4240{
76a01679 4241 struct type *type0 =
df407dfe 4242 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4243 struct type *type1 =
df407dfe 4244 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4245
4c4b4cd2
PH
4246 if (type0 == NULL)
4247 return 0;
4248
14f9c5c9
AS
4249 switch (op)
4250 {
4251 default:
4252 return 0;
4253
4254 case BINOP_ADD:
4255 case BINOP_SUB:
4256 case BINOP_MUL:
4257 case BINOP_DIV:
d2e4a39e 4258 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4259
4260 case BINOP_REM:
4261 case BINOP_MOD:
4262 case BINOP_BITWISE_AND:
4263 case BINOP_BITWISE_IOR:
4264 case BINOP_BITWISE_XOR:
d2e4a39e 4265 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4266
4267 case BINOP_EQUAL:
4268 case BINOP_NOTEQUAL:
4269 case BINOP_LESS:
4270 case BINOP_GTR:
4271 case BINOP_LEQ:
4272 case BINOP_GEQ:
d2e4a39e 4273 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4274
4275 case BINOP_CONCAT:
ee90b9ab 4276 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4277
4278 case BINOP_EXP:
d2e4a39e 4279 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4280
4281 case UNOP_NEG:
4282 case UNOP_PLUS:
4283 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4284 case UNOP_ABS:
4285 return (!numeric_type_p (type0));
14f9c5c9
AS
4286
4287 }
4288}
4289\f
4c4b4cd2 4290 /* Renaming */
14f9c5c9 4291
aeb5907d
JB
4292/* NOTES:
4293
4294 1. In the following, we assume that a renaming type's name may
4295 have an ___XD suffix. It would be nice if this went away at some
4296 point.
4297 2. We handle both the (old) purely type-based representation of
4298 renamings and the (new) variable-based encoding. At some point,
4299 it is devoutly to be hoped that the former goes away
4300 (FIXME: hilfinger-2007-07-09).
4301 3. Subprogram renamings are not implemented, although the XRS
4302 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4303
4304/* If SYM encodes a renaming,
4305
4306 <renaming> renames <renamed entity>,
4307
4308 sets *LEN to the length of the renamed entity's name,
4309 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4310 the string describing the subcomponent selected from the renamed
0963b4bd 4311 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4312 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4313 are undefined). Otherwise, returns a value indicating the category
4314 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4315 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4316 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4317 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4318 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4319 may be NULL, in which case they are not assigned.
4320
4321 [Currently, however, GCC does not generate subprogram renamings.] */
4322
4323enum ada_renaming_category
4324ada_parse_renaming (struct symbol *sym,
4325 const char **renamed_entity, int *len,
4326 const char **renaming_expr)
4327{
4328 enum ada_renaming_category kind;
4329 const char *info;
4330 const char *suffix;
4331
4332 if (sym == NULL)
4333 return ADA_NOT_RENAMING;
4334 switch (SYMBOL_CLASS (sym))
14f9c5c9 4335 {
aeb5907d
JB
4336 default:
4337 return ADA_NOT_RENAMING;
4338 case LOC_TYPEDEF:
4339 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4340 renamed_entity, len, renaming_expr);
4341 case LOC_LOCAL:
4342 case LOC_STATIC:
4343 case LOC_COMPUTED:
4344 case LOC_OPTIMIZED_OUT:
4345 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4346 if (info == NULL)
4347 return ADA_NOT_RENAMING;
4348 switch (info[5])
4349 {
4350 case '_':
4351 kind = ADA_OBJECT_RENAMING;
4352 info += 6;
4353 break;
4354 case 'E':
4355 kind = ADA_EXCEPTION_RENAMING;
4356 info += 7;
4357 break;
4358 case 'P':
4359 kind = ADA_PACKAGE_RENAMING;
4360 info += 7;
4361 break;
4362 case 'S':
4363 kind = ADA_SUBPROGRAM_RENAMING;
4364 info += 7;
4365 break;
4366 default:
4367 return ADA_NOT_RENAMING;
4368 }
14f9c5c9 4369 }
4c4b4cd2 4370
aeb5907d
JB
4371 if (renamed_entity != NULL)
4372 *renamed_entity = info;
4373 suffix = strstr (info, "___XE");
4374 if (suffix == NULL || suffix == info)
4375 return ADA_NOT_RENAMING;
4376 if (len != NULL)
4377 *len = strlen (info) - strlen (suffix);
4378 suffix += 5;
4379 if (renaming_expr != NULL)
4380 *renaming_expr = suffix;
4381 return kind;
4382}
4383
4384/* Assuming TYPE encodes a renaming according to the old encoding in
4385 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4386 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4387 ADA_NOT_RENAMING otherwise. */
4388static enum ada_renaming_category
4389parse_old_style_renaming (struct type *type,
4390 const char **renamed_entity, int *len,
4391 const char **renaming_expr)
4392{
4393 enum ada_renaming_category kind;
4394 const char *name;
4395 const char *info;
4396 const char *suffix;
14f9c5c9 4397
aeb5907d
JB
4398 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4399 || TYPE_NFIELDS (type) != 1)
4400 return ADA_NOT_RENAMING;
14f9c5c9 4401
aeb5907d
JB
4402 name = type_name_no_tag (type);
4403 if (name == NULL)
4404 return ADA_NOT_RENAMING;
4405
4406 name = strstr (name, "___XR");
4407 if (name == NULL)
4408 return ADA_NOT_RENAMING;
4409 switch (name[5])
4410 {
4411 case '\0':
4412 case '_':
4413 kind = ADA_OBJECT_RENAMING;
4414 break;
4415 case 'E':
4416 kind = ADA_EXCEPTION_RENAMING;
4417 break;
4418 case 'P':
4419 kind = ADA_PACKAGE_RENAMING;
4420 break;
4421 case 'S':
4422 kind = ADA_SUBPROGRAM_RENAMING;
4423 break;
4424 default:
4425 return ADA_NOT_RENAMING;
4426 }
14f9c5c9 4427
aeb5907d
JB
4428 info = TYPE_FIELD_NAME (type, 0);
4429 if (info == NULL)
4430 return ADA_NOT_RENAMING;
4431 if (renamed_entity != NULL)
4432 *renamed_entity = info;
4433 suffix = strstr (info, "___XE");
4434 if (renaming_expr != NULL)
4435 *renaming_expr = suffix + 5;
4436 if (suffix == NULL || suffix == info)
4437 return ADA_NOT_RENAMING;
4438 if (len != NULL)
4439 *len = suffix - info;
4440 return kind;
a5ee536b
JB
4441}
4442
4443/* Compute the value of the given RENAMING_SYM, which is expected to
4444 be a symbol encoding a renaming expression. BLOCK is the block
4445 used to evaluate the renaming. */
52ce6436 4446
a5ee536b
JB
4447static struct value *
4448ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4449 const struct block *block)
a5ee536b 4450{
bbc13ae3 4451 const char *sym_name;
a5ee536b 4452
bbc13ae3 4453 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4454 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4455 return evaluate_expression (expr.get ());
a5ee536b 4456}
14f9c5c9 4457\f
d2e4a39e 4458
4c4b4cd2 4459 /* Evaluation: Function Calls */
14f9c5c9 4460
4c4b4cd2 4461/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4462 lvalues, and otherwise has the side-effect of allocating memory
4463 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4464
d2e4a39e 4465static struct value *
40bc484c 4466ensure_lval (struct value *val)
14f9c5c9 4467{
40bc484c
JB
4468 if (VALUE_LVAL (val) == not_lval
4469 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4470 {
df407dfe 4471 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4472 const CORE_ADDR addr =
4473 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4474
a84a8a0d 4475 VALUE_LVAL (val) = lval_memory;
1a088441 4476 set_value_address (val, addr);
40bc484c 4477 write_memory (addr, value_contents (val), len);
c3e5cd34 4478 }
14f9c5c9
AS
4479
4480 return val;
4481}
4482
4483/* Return the value ACTUAL, converted to be an appropriate value for a
4484 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4485 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4486 values not residing in memory, updating it as needed. */
14f9c5c9 4487
a93c0eb6 4488struct value *
40bc484c 4489ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4490{
df407dfe 4491 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4492 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4493 struct type *formal_target =
4494 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4495 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4496 struct type *actual_target =
4497 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4498 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4499
4c4b4cd2 4500 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4501 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4502 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4503 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4504 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4505 {
a84a8a0d 4506 struct value *result;
5b4ee69b 4507
14f9c5c9 4508 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4509 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4510 result = desc_data (actual);
cb923fcc 4511 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4512 {
4513 if (VALUE_LVAL (actual) != lval_memory)
4514 {
4515 struct value *val;
5b4ee69b 4516
df407dfe 4517 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4518 val = allocate_value (actual_type);
990a07ab 4519 memcpy ((char *) value_contents_raw (val),
0fd88904 4520 (char *) value_contents (actual),
4c4b4cd2 4521 TYPE_LENGTH (actual_type));
40bc484c 4522 actual = ensure_lval (val);
4c4b4cd2 4523 }
a84a8a0d 4524 result = value_addr (actual);
4c4b4cd2 4525 }
a84a8a0d
JB
4526 else
4527 return actual;
b1af9e97 4528 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4529 }
4530 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4531 return ada_value_ind (actual);
8344af1e
JB
4532 else if (ada_is_aligner_type (formal_type))
4533 {
4534 /* We need to turn this parameter into an aligner type
4535 as well. */
4536 struct value *aligner = allocate_value (formal_type);
4537 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4538
4539 value_assign_to_component (aligner, component, actual);
4540 return aligner;
4541 }
14f9c5c9
AS
4542
4543 return actual;
4544}
4545
438c98a1
JB
4546/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4547 type TYPE. This is usually an inefficient no-op except on some targets
4548 (such as AVR) where the representation of a pointer and an address
4549 differs. */
4550
4551static CORE_ADDR
4552value_pointer (struct value *value, struct type *type)
4553{
4554 struct gdbarch *gdbarch = get_type_arch (type);
4555 unsigned len = TYPE_LENGTH (type);
224c3ddb 4556 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4557 CORE_ADDR addr;
4558
4559 addr = value_address (value);
4560 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4561 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4562 return addr;
4563}
4564
14f9c5c9 4565
4c4b4cd2
PH
4566/* Push a descriptor of type TYPE for array value ARR on the stack at
4567 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4568 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4569 to-descriptor type rather than a descriptor type), a struct value *
4570 representing a pointer to this descriptor. */
14f9c5c9 4571
d2e4a39e 4572static struct value *
40bc484c 4573make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4574{
d2e4a39e
AS
4575 struct type *bounds_type = desc_bounds_type (type);
4576 struct type *desc_type = desc_base_type (type);
4577 struct value *descriptor = allocate_value (desc_type);
4578 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4579 int i;
d2e4a39e 4580
0963b4bd
MS
4581 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4582 i > 0; i -= 1)
14f9c5c9 4583 {
19f220c3
JK
4584 modify_field (value_type (bounds), value_contents_writeable (bounds),
4585 ada_array_bound (arr, i, 0),
4586 desc_bound_bitpos (bounds_type, i, 0),
4587 desc_bound_bitsize (bounds_type, i, 0));
4588 modify_field (value_type (bounds), value_contents_writeable (bounds),
4589 ada_array_bound (arr, i, 1),
4590 desc_bound_bitpos (bounds_type, i, 1),
4591 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4592 }
d2e4a39e 4593
40bc484c 4594 bounds = ensure_lval (bounds);
d2e4a39e 4595
19f220c3
JK
4596 modify_field (value_type (descriptor),
4597 value_contents_writeable (descriptor),
4598 value_pointer (ensure_lval (arr),
4599 TYPE_FIELD_TYPE (desc_type, 0)),
4600 fat_pntr_data_bitpos (desc_type),
4601 fat_pntr_data_bitsize (desc_type));
4602
4603 modify_field (value_type (descriptor),
4604 value_contents_writeable (descriptor),
4605 value_pointer (bounds,
4606 TYPE_FIELD_TYPE (desc_type, 1)),
4607 fat_pntr_bounds_bitpos (desc_type),
4608 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4609
40bc484c 4610 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4611
4612 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4613 return value_addr (descriptor);
4614 else
4615 return descriptor;
4616}
14f9c5c9 4617\f
3d9434b5
JB
4618 /* Symbol Cache Module */
4619
3d9434b5 4620/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4621 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4622 on the type of entity being printed, the cache can make it as much
4623 as an order of magnitude faster than without it.
4624
4625 The descriptive type DWARF extension has significantly reduced
4626 the need for this cache, at least when DWARF is being used. However,
4627 even in this case, some expensive name-based symbol searches are still
4628 sometimes necessary - to find an XVZ variable, mostly. */
4629
ee01b665 4630/* Initialize the contents of SYM_CACHE. */
3d9434b5 4631
ee01b665
JB
4632static void
4633ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4634{
4635 obstack_init (&sym_cache->cache_space);
4636 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4637}
3d9434b5 4638
ee01b665
JB
4639/* Free the memory used by SYM_CACHE. */
4640
4641static void
4642ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4643{
ee01b665
JB
4644 obstack_free (&sym_cache->cache_space, NULL);
4645 xfree (sym_cache);
4646}
3d9434b5 4647
ee01b665
JB
4648/* Return the symbol cache associated to the given program space PSPACE.
4649 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4650
ee01b665
JB
4651static struct ada_symbol_cache *
4652ada_get_symbol_cache (struct program_space *pspace)
4653{
4654 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4655
66c168ae 4656 if (pspace_data->sym_cache == NULL)
ee01b665 4657 {
66c168ae
JB
4658 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4659 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4660 }
4661
66c168ae 4662 return pspace_data->sym_cache;
ee01b665 4663}
3d9434b5
JB
4664
4665/* Clear all entries from the symbol cache. */
4666
4667static void
4668ada_clear_symbol_cache (void)
4669{
ee01b665
JB
4670 struct ada_symbol_cache *sym_cache
4671 = ada_get_symbol_cache (current_program_space);
4672
4673 obstack_free (&sym_cache->cache_space, NULL);
4674 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4675}
4676
fe978cb0 4677/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4678 Return it if found, or NULL otherwise. */
4679
4680static struct cache_entry **
fe978cb0 4681find_entry (const char *name, domain_enum domain)
3d9434b5 4682{
ee01b665
JB
4683 struct ada_symbol_cache *sym_cache
4684 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4685 int h = msymbol_hash (name) % HASH_SIZE;
4686 struct cache_entry **e;
4687
ee01b665 4688 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4689 {
fe978cb0 4690 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4691 return e;
4692 }
4693 return NULL;
4694}
4695
fe978cb0 4696/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4697 Return 1 if found, 0 otherwise.
4698
4699 If an entry was found and SYM is not NULL, set *SYM to the entry's
4700 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4701
96d887e8 4702static int
fe978cb0 4703lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4704 struct symbol **sym, const struct block **block)
96d887e8 4705{
fe978cb0 4706 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4707
4708 if (e == NULL)
4709 return 0;
4710 if (sym != NULL)
4711 *sym = (*e)->sym;
4712 if (block != NULL)
4713 *block = (*e)->block;
4714 return 1;
96d887e8
PH
4715}
4716
3d9434b5 4717/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4718 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4719
96d887e8 4720static void
fe978cb0 4721cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4722 const struct block *block)
96d887e8 4723{
ee01b665
JB
4724 struct ada_symbol_cache *sym_cache
4725 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4726 int h;
4727 char *copy;
4728 struct cache_entry *e;
4729
1994afbf
DE
4730 /* Symbols for builtin types don't have a block.
4731 For now don't cache such symbols. */
4732 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4733 return;
4734
3d9434b5
JB
4735 /* If the symbol is a local symbol, then do not cache it, as a search
4736 for that symbol depends on the context. To determine whether
4737 the symbol is local or not, we check the block where we found it
4738 against the global and static blocks of its associated symtab. */
4739 if (sym
08be3fe3 4740 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4741 GLOBAL_BLOCK) != block
08be3fe3 4742 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4743 STATIC_BLOCK) != block)
3d9434b5
JB
4744 return;
4745
4746 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4747 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4748 sizeof (*e));
4749 e->next = sym_cache->root[h];
4750 sym_cache->root[h] = e;
224c3ddb
SM
4751 e->name = copy
4752 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4753 strcpy (copy, name);
4754 e->sym = sym;
fe978cb0 4755 e->domain = domain;
3d9434b5 4756 e->block = block;
96d887e8 4757}
4c4b4cd2
PH
4758\f
4759 /* Symbol Lookup */
4760
b5ec771e
PA
4761/* Return the symbol name match type that should be used used when
4762 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4763
4764 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4765 for Ada lookups. */
c0431670 4766
b5ec771e
PA
4767static symbol_name_match_type
4768name_match_type_from_name (const char *lookup_name)
c0431670 4769{
b5ec771e
PA
4770 return (strstr (lookup_name, "__") == NULL
4771 ? symbol_name_match_type::WILD
4772 : symbol_name_match_type::FULL);
c0431670
JB
4773}
4774
4c4b4cd2
PH
4775/* Return the result of a standard (literal, C-like) lookup of NAME in
4776 given DOMAIN, visible from lexical block BLOCK. */
4777
4778static struct symbol *
4779standard_lookup (const char *name, const struct block *block,
4780 domain_enum domain)
4781{
acbd605d 4782 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4783 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4784
d12307c1
PMR
4785 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4786 return sym.symbol;
2570f2b7 4787 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4788 cache_symbol (name, domain, sym.symbol, sym.block);
4789 return sym.symbol;
4c4b4cd2
PH
4790}
4791
4792
4793/* Non-zero iff there is at least one non-function/non-enumeral symbol
4794 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4795 since they contend in overloading in the same way. */
4796static int
d12307c1 4797is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4798{
4799 int i;
4800
4801 for (i = 0; i < n; i += 1)
d12307c1
PMR
4802 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4803 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4804 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4805 return 1;
4806
4807 return 0;
4808}
4809
4810/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4811 struct types. Otherwise, they may not. */
14f9c5c9
AS
4812
4813static int
d2e4a39e 4814equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4815{
d2e4a39e 4816 if (type0 == type1)
14f9c5c9 4817 return 1;
d2e4a39e 4818 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4819 || TYPE_CODE (type0) != TYPE_CODE (type1))
4820 return 0;
d2e4a39e 4821 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4822 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4823 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4824 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4825 return 1;
d2e4a39e 4826
14f9c5c9
AS
4827 return 0;
4828}
4829
4830/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4831 no more defined than that of SYM1. */
14f9c5c9
AS
4832
4833static int
d2e4a39e 4834lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4835{
4836 if (sym0 == sym1)
4837 return 1;
176620f1 4838 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4839 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4840 return 0;
4841
d2e4a39e 4842 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4843 {
4844 case LOC_UNDEF:
4845 return 1;
4846 case LOC_TYPEDEF:
4847 {
4c4b4cd2
PH
4848 struct type *type0 = SYMBOL_TYPE (sym0);
4849 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4850 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4851 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4852 int len0 = strlen (name0);
5b4ee69b 4853
4c4b4cd2
PH
4854 return
4855 TYPE_CODE (type0) == TYPE_CODE (type1)
4856 && (equiv_types (type0, type1)
4857 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4858 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4859 }
4860 case LOC_CONST:
4861 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4862 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4863 default:
4864 return 0;
14f9c5c9
AS
4865 }
4866}
4867
d12307c1 4868/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4869 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4870
4871static void
76a01679
JB
4872add_defn_to_vec (struct obstack *obstackp,
4873 struct symbol *sym,
f0c5f9b2 4874 const struct block *block)
14f9c5c9
AS
4875{
4876 int i;
d12307c1 4877 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4878
529cad9c
PH
4879 /* Do not try to complete stub types, as the debugger is probably
4880 already scanning all symbols matching a certain name at the
4881 time when this function is called. Trying to replace the stub
4882 type by its associated full type will cause us to restart a scan
4883 which may lead to an infinite recursion. Instead, the client
4884 collecting the matching symbols will end up collecting several
4885 matches, with at least one of them complete. It can then filter
4886 out the stub ones if needed. */
4887
4c4b4cd2
PH
4888 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4889 {
d12307c1 4890 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4891 return;
d12307c1 4892 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4893 {
d12307c1 4894 prevDefns[i].symbol = sym;
4c4b4cd2 4895 prevDefns[i].block = block;
4c4b4cd2 4896 return;
76a01679 4897 }
4c4b4cd2
PH
4898 }
4899
4900 {
d12307c1 4901 struct block_symbol info;
4c4b4cd2 4902
d12307c1 4903 info.symbol = sym;
4c4b4cd2 4904 info.block = block;
d12307c1 4905 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4906 }
4907}
4908
d12307c1
PMR
4909/* Number of block_symbol structures currently collected in current vector in
4910 OBSTACKP. */
4c4b4cd2 4911
76a01679
JB
4912static int
4913num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4914{
d12307c1 4915 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4916}
4917
d12307c1
PMR
4918/* Vector of block_symbol structures currently collected in current vector in
4919 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4920
d12307c1 4921static struct block_symbol *
4c4b4cd2
PH
4922defns_collected (struct obstack *obstackp, int finish)
4923{
4924 if (finish)
224c3ddb 4925 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4926 else
d12307c1 4927 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4928}
4929
7c7b6655
TT
4930/* Return a bound minimal symbol matching NAME according to Ada
4931 decoding rules. Returns an invalid symbol if there is no such
4932 minimal symbol. Names prefixed with "standard__" are handled
4933 specially: "standard__" is first stripped off, and only static and
4934 global symbols are searched. */
4c4b4cd2 4935
7c7b6655 4936struct bound_minimal_symbol
96d887e8 4937ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4938{
7c7b6655 4939 struct bound_minimal_symbol result;
4c4b4cd2 4940 struct objfile *objfile;
96d887e8 4941 struct minimal_symbol *msymbol;
4c4b4cd2 4942
7c7b6655
TT
4943 memset (&result, 0, sizeof (result));
4944
b5ec771e
PA
4945 symbol_name_match_type match_type = name_match_type_from_name (name);
4946 lookup_name_info lookup_name (name, match_type);
4947
4948 symbol_name_matcher_ftype *match_name
4949 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4950
96d887e8
PH
4951 ALL_MSYMBOLS (objfile, msymbol)
4952 {
b5ec771e 4953 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
96d887e8 4954 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4955 {
4956 result.minsym = msymbol;
4957 result.objfile = objfile;
4958 break;
4959 }
96d887e8 4960 }
4c4b4cd2 4961
7c7b6655 4962 return result;
96d887e8 4963}
4c4b4cd2 4964
96d887e8
PH
4965/* For all subprograms that statically enclose the subprogram of the
4966 selected frame, add symbols matching identifier NAME in DOMAIN
4967 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4968 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4969 with a wildcard prefix. */
4c4b4cd2 4970
96d887e8
PH
4971static void
4972add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4973 const lookup_name_info &lookup_name,
4974 domain_enum domain)
96d887e8 4975{
96d887e8 4976}
14f9c5c9 4977
96d887e8
PH
4978/* True if TYPE is definitely an artificial type supplied to a symbol
4979 for which no debugging information was given in the symbol file. */
14f9c5c9 4980
96d887e8
PH
4981static int
4982is_nondebugging_type (struct type *type)
4983{
0d5cff50 4984 const char *name = ada_type_name (type);
5b4ee69b 4985
96d887e8
PH
4986 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4987}
4c4b4cd2 4988
8f17729f
JB
4989/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4990 that are deemed "identical" for practical purposes.
4991
4992 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4993 types and that their number of enumerals is identical (in other
4994 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4995
4996static int
4997ada_identical_enum_types_p (struct type *type1, struct type *type2)
4998{
4999 int i;
5000
5001 /* The heuristic we use here is fairly conservative. We consider
5002 that 2 enumerate types are identical if they have the same
5003 number of enumerals and that all enumerals have the same
5004 underlying value and name. */
5005
5006 /* All enums in the type should have an identical underlying value. */
5007 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 5008 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
5009 return 0;
5010
5011 /* All enumerals should also have the same name (modulo any numerical
5012 suffix). */
5013 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5014 {
0d5cff50
DE
5015 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5016 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5017 int len_1 = strlen (name_1);
5018 int len_2 = strlen (name_2);
5019
5020 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5021 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5022 if (len_1 != len_2
5023 || strncmp (TYPE_FIELD_NAME (type1, i),
5024 TYPE_FIELD_NAME (type2, i),
5025 len_1) != 0)
5026 return 0;
5027 }
5028
5029 return 1;
5030}
5031
5032/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5033 that are deemed "identical" for practical purposes. Sometimes,
5034 enumerals are not strictly identical, but their types are so similar
5035 that they can be considered identical.
5036
5037 For instance, consider the following code:
5038
5039 type Color is (Black, Red, Green, Blue, White);
5040 type RGB_Color is new Color range Red .. Blue;
5041
5042 Type RGB_Color is a subrange of an implicit type which is a copy
5043 of type Color. If we call that implicit type RGB_ColorB ("B" is
5044 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5045 As a result, when an expression references any of the enumeral
5046 by name (Eg. "print green"), the expression is technically
5047 ambiguous and the user should be asked to disambiguate. But
5048 doing so would only hinder the user, since it wouldn't matter
5049 what choice he makes, the outcome would always be the same.
5050 So, for practical purposes, we consider them as the same. */
5051
5052static int
d12307c1 5053symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
8f17729f
JB
5054{
5055 int i;
5056
5057 /* Before performing a thorough comparison check of each type,
5058 we perform a series of inexpensive checks. We expect that these
5059 checks will quickly fail in the vast majority of cases, and thus
5060 help prevent the unnecessary use of a more expensive comparison.
5061 Said comparison also expects us to make some of these checks
5062 (see ada_identical_enum_types_p). */
5063
5064 /* Quick check: All symbols should have an enum type. */
5065 for (i = 0; i < nsyms; i++)
d12307c1 5066 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5067 return 0;
5068
5069 /* Quick check: They should all have the same value. */
5070 for (i = 1; i < nsyms; i++)
d12307c1 5071 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5072 return 0;
5073
5074 /* Quick check: They should all have the same number of enumerals. */
5075 for (i = 1; i < nsyms; i++)
d12307c1
PMR
5076 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5077 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5078 return 0;
5079
5080 /* All the sanity checks passed, so we might have a set of
5081 identical enumeration types. Perform a more complete
5082 comparison of the type of each symbol. */
5083 for (i = 1; i < nsyms; i++)
d12307c1
PMR
5084 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5085 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5086 return 0;
5087
5088 return 1;
5089}
5090
96d887e8
PH
5091/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5092 duplicate other symbols in the list (The only case I know of where
5093 this happens is when object files containing stabs-in-ecoff are
5094 linked with files containing ordinary ecoff debugging symbols (or no
5095 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5096 Returns the number of items in the modified list. */
4c4b4cd2 5097
96d887e8 5098static int
d12307c1 5099remove_extra_symbols (struct block_symbol *syms, int nsyms)
96d887e8
PH
5100{
5101 int i, j;
4c4b4cd2 5102
8f17729f
JB
5103 /* We should never be called with less than 2 symbols, as there
5104 cannot be any extra symbol in that case. But it's easy to
5105 handle, since we have nothing to do in that case. */
5106 if (nsyms < 2)
5107 return nsyms;
5108
96d887e8
PH
5109 i = 0;
5110 while (i < nsyms)
5111 {
a35ddb44 5112 int remove_p = 0;
339c13b6
JB
5113
5114 /* If two symbols have the same name and one of them is a stub type,
5115 the get rid of the stub. */
5116
d12307c1
PMR
5117 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5118 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
339c13b6
JB
5119 {
5120 for (j = 0; j < nsyms; j++)
5121 {
5122 if (j != i
d12307c1
PMR
5123 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5124 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5125 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5126 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
a35ddb44 5127 remove_p = 1;
339c13b6
JB
5128 }
5129 }
5130
5131 /* Two symbols with the same name, same class and same address
5132 should be identical. */
5133
d12307c1
PMR
5134 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5135 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5136 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
96d887e8
PH
5137 {
5138 for (j = 0; j < nsyms; j += 1)
5139 {
5140 if (i != j
d12307c1
PMR
5141 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5142 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5143 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5144 && SYMBOL_CLASS (syms[i].symbol)
5145 == SYMBOL_CLASS (syms[j].symbol)
5146 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5147 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
a35ddb44 5148 remove_p = 1;
4c4b4cd2 5149 }
4c4b4cd2 5150 }
339c13b6 5151
a35ddb44 5152 if (remove_p)
339c13b6
JB
5153 {
5154 for (j = i + 1; j < nsyms; j += 1)
5155 syms[j - 1] = syms[j];
5156 nsyms -= 1;
5157 }
5158
96d887e8 5159 i += 1;
14f9c5c9 5160 }
8f17729f
JB
5161
5162 /* If all the remaining symbols are identical enumerals, then
5163 just keep the first one and discard the rest.
5164
5165 Unlike what we did previously, we do not discard any entry
5166 unless they are ALL identical. This is because the symbol
5167 comparison is not a strict comparison, but rather a practical
5168 comparison. If all symbols are considered identical, then
5169 we can just go ahead and use the first one and discard the rest.
5170 But if we cannot reduce the list to a single element, we have
5171 to ask the user to disambiguate anyways. And if we have to
5172 present a multiple-choice menu, it's less confusing if the list
5173 isn't missing some choices that were identical and yet distinct. */
5174 if (symbols_are_identical_enums (syms, nsyms))
5175 nsyms = 1;
5176
96d887e8 5177 return nsyms;
14f9c5c9
AS
5178}
5179
96d887e8
PH
5180/* Given a type that corresponds to a renaming entity, use the type name
5181 to extract the scope (package name or function name, fully qualified,
5182 and following the GNAT encoding convention) where this renaming has been
49d83361 5183 defined. */
4c4b4cd2 5184
49d83361 5185static std::string
96d887e8 5186xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5187{
96d887e8 5188 /* The renaming types adhere to the following convention:
0963b4bd 5189 <scope>__<rename>___<XR extension>.
96d887e8
PH
5190 So, to extract the scope, we search for the "___XR" extension,
5191 and then backtrack until we find the first "__". */
76a01679 5192
96d887e8 5193 const char *name = type_name_no_tag (renaming_type);
108d56a4
SM
5194 const char *suffix = strstr (name, "___XR");
5195 const char *last;
14f9c5c9 5196
96d887e8
PH
5197 /* Now, backtrack a bit until we find the first "__". Start looking
5198 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5199
96d887e8
PH
5200 for (last = suffix - 3; last > name; last--)
5201 if (last[0] == '_' && last[1] == '_')
5202 break;
76a01679 5203
96d887e8 5204 /* Make a copy of scope and return it. */
49d83361 5205 return std::string (name, last);
4c4b4cd2
PH
5206}
5207
96d887e8 5208/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5209
96d887e8
PH
5210static int
5211is_package_name (const char *name)
4c4b4cd2 5212{
96d887e8
PH
5213 /* Here, We take advantage of the fact that no symbols are generated
5214 for packages, while symbols are generated for each function.
5215 So the condition for NAME represent a package becomes equivalent
5216 to NAME not existing in our list of symbols. There is only one
5217 small complication with library-level functions (see below). */
4c4b4cd2 5218
96d887e8 5219 char *fun_name;
76a01679 5220
96d887e8
PH
5221 /* If it is a function that has not been defined at library level,
5222 then we should be able to look it up in the symbols. */
5223 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5224 return 0;
14f9c5c9 5225
96d887e8
PH
5226 /* Library-level function names start with "_ada_". See if function
5227 "_ada_" followed by NAME can be found. */
14f9c5c9 5228
96d887e8 5229 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5230 functions names cannot contain "__" in them. */
96d887e8
PH
5231 if (strstr (name, "__") != NULL)
5232 return 0;
4c4b4cd2 5233
b435e160 5234 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 5235
96d887e8
PH
5236 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5237}
14f9c5c9 5238
96d887e8 5239/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5240 not visible from FUNCTION_NAME. */
14f9c5c9 5241
96d887e8 5242static int
0d5cff50 5243old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5244{
aeb5907d
JB
5245 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5246 return 0;
5247
49d83361 5248 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5249
96d887e8 5250 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5251 if (is_package_name (scope.c_str ()))
5252 return 0;
14f9c5c9 5253
96d887e8
PH
5254 /* Check that the rename is in the current function scope by checking
5255 that its name starts with SCOPE. */
76a01679 5256
96d887e8
PH
5257 /* If the function name starts with "_ada_", it means that it is
5258 a library-level function. Strip this prefix before doing the
5259 comparison, as the encoding for the renaming does not contain
5260 this prefix. */
61012eef 5261 if (startswith (function_name, "_ada_"))
96d887e8 5262 function_name += 5;
f26caa11 5263
49d83361 5264 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5265}
5266
aeb5907d
JB
5267/* Remove entries from SYMS that corresponds to a renaming entity that
5268 is not visible from the function associated with CURRENT_BLOCK or
5269 that is superfluous due to the presence of more specific renaming
5270 information. Places surviving symbols in the initial entries of
5271 SYMS and returns the number of surviving symbols.
96d887e8
PH
5272
5273 Rationale:
aeb5907d
JB
5274 First, in cases where an object renaming is implemented as a
5275 reference variable, GNAT may produce both the actual reference
5276 variable and the renaming encoding. In this case, we discard the
5277 latter.
5278
5279 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5280 entity. Unfortunately, STABS currently does not support the definition
5281 of types that are local to a given lexical block, so all renamings types
5282 are emitted at library level. As a consequence, if an application
5283 contains two renaming entities using the same name, and a user tries to
5284 print the value of one of these entities, the result of the ada symbol
5285 lookup will also contain the wrong renaming type.
f26caa11 5286
96d887e8
PH
5287 This function partially covers for this limitation by attempting to
5288 remove from the SYMS list renaming symbols that should be visible
5289 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5290 method with the current information available. The implementation
5291 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5292
5293 - When the user tries to print a rename in a function while there
5294 is another rename entity defined in a package: Normally, the
5295 rename in the function has precedence over the rename in the
5296 package, so the latter should be removed from the list. This is
5297 currently not the case.
5298
5299 - This function will incorrectly remove valid renames if
5300 the CURRENT_BLOCK corresponds to a function which symbol name
5301 has been changed by an "Export" pragma. As a consequence,
5302 the user will be unable to print such rename entities. */
4c4b4cd2 5303
14f9c5c9 5304static int
d12307c1 5305remove_irrelevant_renamings (struct block_symbol *syms,
aeb5907d 5306 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5307{
5308 struct symbol *current_function;
0d5cff50 5309 const char *current_function_name;
4c4b4cd2 5310 int i;
aeb5907d
JB
5311 int is_new_style_renaming;
5312
5313 /* If there is both a renaming foo___XR... encoded as a variable and
5314 a simple variable foo in the same block, discard the latter.
0963b4bd 5315 First, zero out such symbols, then compress. */
aeb5907d
JB
5316 is_new_style_renaming = 0;
5317 for (i = 0; i < nsyms; i += 1)
5318 {
d12307c1 5319 struct symbol *sym = syms[i].symbol;
270140bd 5320 const struct block *block = syms[i].block;
aeb5907d
JB
5321 const char *name;
5322 const char *suffix;
5323
5324 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5325 continue;
5326 name = SYMBOL_LINKAGE_NAME (sym);
5327 suffix = strstr (name, "___XR");
5328
5329 if (suffix != NULL)
5330 {
5331 int name_len = suffix - name;
5332 int j;
5b4ee69b 5333
aeb5907d
JB
5334 is_new_style_renaming = 1;
5335 for (j = 0; j < nsyms; j += 1)
d12307c1
PMR
5336 if (i != j && syms[j].symbol != NULL
5337 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
aeb5907d
JB
5338 name_len) == 0
5339 && block == syms[j].block)
d12307c1 5340 syms[j].symbol = NULL;
aeb5907d
JB
5341 }
5342 }
5343 if (is_new_style_renaming)
5344 {
5345 int j, k;
5346
5347 for (j = k = 0; j < nsyms; j += 1)
d12307c1 5348 if (syms[j].symbol != NULL)
aeb5907d
JB
5349 {
5350 syms[k] = syms[j];
5351 k += 1;
5352 }
5353 return k;
5354 }
4c4b4cd2
PH
5355
5356 /* Extract the function name associated to CURRENT_BLOCK.
5357 Abort if unable to do so. */
76a01679 5358
4c4b4cd2
PH
5359 if (current_block == NULL)
5360 return nsyms;
76a01679 5361
7f0df278 5362 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5363 if (current_function == NULL)
5364 return nsyms;
5365
5366 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5367 if (current_function_name == NULL)
5368 return nsyms;
5369
5370 /* Check each of the symbols, and remove it from the list if it is
5371 a type corresponding to a renaming that is out of the scope of
5372 the current block. */
5373
5374 i = 0;
5375 while (i < nsyms)
5376 {
d12307c1 5377 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
aeb5907d 5378 == ADA_OBJECT_RENAMING
d12307c1 5379 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
4c4b4cd2
PH
5380 {
5381 int j;
5b4ee69b 5382
aeb5907d 5383 for (j = i + 1; j < nsyms; j += 1)
76a01679 5384 syms[j - 1] = syms[j];
4c4b4cd2
PH
5385 nsyms -= 1;
5386 }
5387 else
5388 i += 1;
5389 }
5390
5391 return nsyms;
5392}
5393
339c13b6
JB
5394/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5395 whose name and domain match NAME and DOMAIN respectively.
5396 If no match was found, then extend the search to "enclosing"
5397 routines (in other words, if we're inside a nested function,
5398 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5399 If WILD_MATCH_P is nonzero, perform the naming matching in
5400 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5401
5402 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5403
5404static void
b5ec771e
PA
5405ada_add_local_symbols (struct obstack *obstackp,
5406 const lookup_name_info &lookup_name,
5407 const struct block *block, domain_enum domain)
339c13b6
JB
5408{
5409 int block_depth = 0;
5410
5411 while (block != NULL)
5412 {
5413 block_depth += 1;
b5ec771e 5414 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5415
5416 /* If we found a non-function match, assume that's the one. */
5417 if (is_nonfunction (defns_collected (obstackp, 0),
5418 num_defns_collected (obstackp)))
5419 return;
5420
5421 block = BLOCK_SUPERBLOCK (block);
5422 }
5423
5424 /* If no luck so far, try to find NAME as a local symbol in some lexically
5425 enclosing subprogram. */
5426 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5427 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5428}
5429
ccefe4c4 5430/* An object of this type is used as the user_data argument when
40658b94 5431 calling the map_matching_symbols method. */
ccefe4c4 5432
40658b94 5433struct match_data
ccefe4c4 5434{
40658b94 5435 struct objfile *objfile;
ccefe4c4 5436 struct obstack *obstackp;
40658b94
PH
5437 struct symbol *arg_sym;
5438 int found_sym;
ccefe4c4
TT
5439};
5440
22cee43f 5441/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5442 to a list of symbols. DATA0 is a pointer to a struct match_data *
5443 containing the obstack that collects the symbol list, the file that SYM
5444 must come from, a flag indicating whether a non-argument symbol has
5445 been found in the current block, and the last argument symbol
5446 passed in SYM within the current block (if any). When SYM is null,
5447 marking the end of a block, the argument symbol is added if no
5448 other has been found. */
ccefe4c4 5449
40658b94
PH
5450static int
5451aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5452{
40658b94
PH
5453 struct match_data *data = (struct match_data *) data0;
5454
5455 if (sym == NULL)
5456 {
5457 if (!data->found_sym && data->arg_sym != NULL)
5458 add_defn_to_vec (data->obstackp,
5459 fixup_symbol_section (data->arg_sym, data->objfile),
5460 block);
5461 data->found_sym = 0;
5462 data->arg_sym = NULL;
5463 }
5464 else
5465 {
5466 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5467 return 0;
5468 else if (SYMBOL_IS_ARGUMENT (sym))
5469 data->arg_sym = sym;
5470 else
5471 {
5472 data->found_sym = 1;
5473 add_defn_to_vec (data->obstackp,
5474 fixup_symbol_section (sym, data->objfile),
5475 block);
5476 }
5477 }
5478 return 0;
5479}
5480
b5ec771e
PA
5481/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5482 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5483 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5484
5485static int
5486ada_add_block_renamings (struct obstack *obstackp,
5487 const struct block *block,
b5ec771e
PA
5488 const lookup_name_info &lookup_name,
5489 domain_enum domain)
22cee43f
PMR
5490{
5491 struct using_direct *renaming;
5492 int defns_mark = num_defns_collected (obstackp);
5493
b5ec771e
PA
5494 symbol_name_matcher_ftype *name_match
5495 = ada_get_symbol_name_matcher (lookup_name);
5496
22cee43f
PMR
5497 for (renaming = block_using (block);
5498 renaming != NULL;
5499 renaming = renaming->next)
5500 {
5501 const char *r_name;
22cee43f
PMR
5502
5503 /* Avoid infinite recursions: skip this renaming if we are actually
5504 already traversing it.
5505
5506 Currently, symbol lookup in Ada don't use the namespace machinery from
5507 C++/Fortran support: skip namespace imports that use them. */
5508 if (renaming->searched
5509 || (renaming->import_src != NULL
5510 && renaming->import_src[0] != '\0')
5511 || (renaming->import_dest != NULL
5512 && renaming->import_dest[0] != '\0'))
5513 continue;
5514 renaming->searched = 1;
5515
5516 /* TODO: here, we perform another name-based symbol lookup, which can
5517 pull its own multiple overloads. In theory, we should be able to do
5518 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5519 not a simple name. But in order to do this, we would need to enhance
5520 the DWARF reader to associate a symbol to this renaming, instead of a
5521 name. So, for now, we do something simpler: re-use the C++/Fortran
5522 namespace machinery. */
5523 r_name = (renaming->alias != NULL
5524 ? renaming->alias
5525 : renaming->declaration);
b5ec771e
PA
5526 if (name_match (r_name, lookup_name, NULL))
5527 {
5528 lookup_name_info decl_lookup_name (renaming->declaration,
5529 lookup_name.match_type ());
5530 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5531 1, NULL);
5532 }
22cee43f
PMR
5533 renaming->searched = 0;
5534 }
5535 return num_defns_collected (obstackp) != defns_mark;
5536}
5537
db230ce3
JB
5538/* Implements compare_names, but only applying the comparision using
5539 the given CASING. */
5b4ee69b 5540
40658b94 5541static int
db230ce3
JB
5542compare_names_with_case (const char *string1, const char *string2,
5543 enum case_sensitivity casing)
40658b94
PH
5544{
5545 while (*string1 != '\0' && *string2 != '\0')
5546 {
db230ce3
JB
5547 char c1, c2;
5548
40658b94
PH
5549 if (isspace (*string1) || isspace (*string2))
5550 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5551
5552 if (casing == case_sensitive_off)
5553 {
5554 c1 = tolower (*string1);
5555 c2 = tolower (*string2);
5556 }
5557 else
5558 {
5559 c1 = *string1;
5560 c2 = *string2;
5561 }
5562 if (c1 != c2)
40658b94 5563 break;
db230ce3 5564
40658b94
PH
5565 string1 += 1;
5566 string2 += 1;
5567 }
db230ce3 5568
40658b94
PH
5569 switch (*string1)
5570 {
5571 case '(':
5572 return strcmp_iw_ordered (string1, string2);
5573 case '_':
5574 if (*string2 == '\0')
5575 {
052874e8 5576 if (is_name_suffix (string1))
40658b94
PH
5577 return 0;
5578 else
1a1d5513 5579 return 1;
40658b94 5580 }
dbb8534f 5581 /* FALLTHROUGH */
40658b94
PH
5582 default:
5583 if (*string2 == '(')
5584 return strcmp_iw_ordered (string1, string2);
5585 else
db230ce3
JB
5586 {
5587 if (casing == case_sensitive_off)
5588 return tolower (*string1) - tolower (*string2);
5589 else
5590 return *string1 - *string2;
5591 }
40658b94 5592 }
ccefe4c4
TT
5593}
5594
db230ce3
JB
5595/* Compare STRING1 to STRING2, with results as for strcmp.
5596 Compatible with strcmp_iw_ordered in that...
5597
5598 strcmp_iw_ordered (STRING1, STRING2) <= 0
5599
5600 ... implies...
5601
5602 compare_names (STRING1, STRING2) <= 0
5603
5604 (they may differ as to what symbols compare equal). */
5605
5606static int
5607compare_names (const char *string1, const char *string2)
5608{
5609 int result;
5610
5611 /* Similar to what strcmp_iw_ordered does, we need to perform
5612 a case-insensitive comparison first, and only resort to
5613 a second, case-sensitive, comparison if the first one was
5614 not sufficient to differentiate the two strings. */
5615
5616 result = compare_names_with_case (string1, string2, case_sensitive_off);
5617 if (result == 0)
5618 result = compare_names_with_case (string1, string2, case_sensitive_on);
5619
5620 return result;
5621}
5622
b5ec771e
PA
5623/* Convenience function to get at the Ada encoded lookup name for
5624 LOOKUP_NAME, as a C string. */
5625
5626static const char *
5627ada_lookup_name (const lookup_name_info &lookup_name)
5628{
5629 return lookup_name.ada ().lookup_name ().c_str ();
5630}
5631
339c13b6 5632/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5633 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5634 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5635 symbols otherwise. */
339c13b6
JB
5636
5637static void
b5ec771e
PA
5638add_nonlocal_symbols (struct obstack *obstackp,
5639 const lookup_name_info &lookup_name,
5640 domain_enum domain, int global)
339c13b6
JB
5641{
5642 struct objfile *objfile;
22cee43f 5643 struct compunit_symtab *cu;
40658b94 5644 struct match_data data;
339c13b6 5645
6475f2fe 5646 memset (&data, 0, sizeof data);
ccefe4c4 5647 data.obstackp = obstackp;
339c13b6 5648
b5ec771e
PA
5649 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5650
ccefe4c4 5651 ALL_OBJFILES (objfile)
40658b94
PH
5652 {
5653 data.objfile = objfile;
5654
5655 if (is_wild_match)
b5ec771e
PA
5656 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5657 domain, global,
4186eb54 5658 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5659 symbol_name_match_type::WILD,
5660 NULL);
40658b94 5661 else
b5ec771e
PA
5662 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5663 domain, global,
4186eb54 5664 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5665 symbol_name_match_type::FULL,
5666 compare_names);
22cee43f
PMR
5667
5668 ALL_OBJFILE_COMPUNITS (objfile, cu)
5669 {
5670 const struct block *global_block
5671 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5672
b5ec771e
PA
5673 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5674 domain))
22cee43f
PMR
5675 data.found_sym = 1;
5676 }
40658b94
PH
5677 }
5678
5679 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5680 {
b5ec771e
PA
5681 const char *name = ada_lookup_name (lookup_name);
5682 std::string name1 = std::string ("<_ada_") + name + '>';
5683
40658b94
PH
5684 ALL_OBJFILES (objfile)
5685 {
40658b94 5686 data.objfile = objfile;
b5ec771e
PA
5687 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5688 domain, global,
0963b4bd
MS
5689 aux_add_nonlocal_symbols,
5690 &data,
b5ec771e
PA
5691 symbol_name_match_type::FULL,
5692 compare_names);
40658b94
PH
5693 }
5694 }
339c13b6
JB
5695}
5696
b5ec771e
PA
5697/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5698 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5699 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5700
22cee43f
PMR
5701 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5702 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5703 is the one match returned (no other matches in that or
d9680e73 5704 enclosing blocks is returned). If there are any matches in or
22cee43f 5705 surrounding BLOCK, then these alone are returned.
4eeaa230 5706
b5ec771e
PA
5707 Names prefixed with "standard__" are handled specially:
5708 "standard__" is first stripped off (by the lookup_name
5709 constructor), and only static and global symbols are searched.
14f9c5c9 5710
22cee43f
PMR
5711 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5712 to lookup global symbols. */
5713
5714static void
5715ada_add_all_symbols (struct obstack *obstackp,
5716 const struct block *block,
b5ec771e 5717 const lookup_name_info &lookup_name,
22cee43f
PMR
5718 domain_enum domain,
5719 int full_search,
5720 int *made_global_lookup_p)
14f9c5c9
AS
5721{
5722 struct symbol *sym;
14f9c5c9 5723
22cee43f
PMR
5724 if (made_global_lookup_p)
5725 *made_global_lookup_p = 0;
339c13b6
JB
5726
5727 /* Special case: If the user specifies a symbol name inside package
5728 Standard, do a non-wild matching of the symbol name without
5729 the "standard__" prefix. This was primarily introduced in order
5730 to allow the user to specifically access the standard exceptions
5731 using, for instance, Standard.Constraint_Error when Constraint_Error
5732 is ambiguous (due to the user defining its own Constraint_Error
5733 entity inside its program). */
b5ec771e
PA
5734 if (lookup_name.ada ().standard_p ())
5735 block = NULL;
4c4b4cd2 5736
339c13b6 5737 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5738
4eeaa230
DE
5739 if (block != NULL)
5740 {
5741 if (full_search)
b5ec771e 5742 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5743 else
5744 {
5745 /* In the !full_search case we're are being called by
5746 ada_iterate_over_symbols, and we don't want to search
5747 superblocks. */
b5ec771e 5748 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5749 }
22cee43f
PMR
5750 if (num_defns_collected (obstackp) > 0 || !full_search)
5751 return;
4eeaa230 5752 }
d2e4a39e 5753
339c13b6
JB
5754 /* No non-global symbols found. Check our cache to see if we have
5755 already performed this search before. If we have, then return
5756 the same result. */
5757
b5ec771e
PA
5758 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5759 domain, &sym, &block))
4c4b4cd2
PH
5760 {
5761 if (sym != NULL)
b5ec771e 5762 add_defn_to_vec (obstackp, sym, block);
22cee43f 5763 return;
4c4b4cd2 5764 }
14f9c5c9 5765
22cee43f
PMR
5766 if (made_global_lookup_p)
5767 *made_global_lookup_p = 1;
b1eedac9 5768
339c13b6
JB
5769 /* Search symbols from all global blocks. */
5770
b5ec771e 5771 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5772
4c4b4cd2 5773 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5774 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5775
22cee43f 5776 if (num_defns_collected (obstackp) == 0)
b5ec771e 5777 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5778}
5779
b5ec771e
PA
5780/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5781 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5782 matches.
ec6a20c2 5783 Sets *RESULTS to point to a newly allocated vector of (SYM,BLOCK) tuples,
22cee43f 5784 indicating the symbols found and the blocks and symbol tables (if
ec6a20c2
JB
5785 any) in which they were found. This vector should be freed when
5786 no longer useful.
22cee43f
PMR
5787
5788 When full_search is non-zero, any non-function/non-enumeral
5789 symbol match within the nest of blocks whose innermost member is BLOCK,
5790 is the one match returned (no other matches in that or
5791 enclosing blocks is returned). If there are any matches in or
5792 surrounding BLOCK, then these alone are returned.
5793
5794 Names prefixed with "standard__" are handled specially: "standard__"
5795 is first stripped off, and only static and global symbols are searched. */
5796
5797static int
b5ec771e
PA
5798ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5799 const struct block *block,
22cee43f
PMR
5800 domain_enum domain,
5801 struct block_symbol **results,
5802 int full_search)
5803{
22cee43f
PMR
5804 int syms_from_global_search;
5805 int ndefns;
ec6a20c2
JB
5806 int results_size;
5807 auto_obstack obstack;
22cee43f 5808
ec6a20c2 5809 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5810 domain, full_search, &syms_from_global_search);
14f9c5c9 5811
ec6a20c2
JB
5812 ndefns = num_defns_collected (&obstack);
5813
5814 results_size = obstack_object_size (&obstack);
5815 *results = (struct block_symbol *) malloc (results_size);
5816 memcpy (*results, defns_collected (&obstack, 1), results_size);
4c4b4cd2
PH
5817
5818 ndefns = remove_extra_symbols (*results, ndefns);
5819
b1eedac9 5820 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5821 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5822
b1eedac9 5823 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5824 cache_symbol (ada_lookup_name (lookup_name), domain,
5825 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5826
22cee43f 5827 ndefns = remove_irrelevant_renamings (*results, ndefns, block);
ec6a20c2 5828
14f9c5c9
AS
5829 return ndefns;
5830}
5831
b5ec771e 5832/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
4eeaa230 5833 in global scopes, returning the number of matches, and setting *RESULTS
ec6a20c2
JB
5834 to a newly-allocated vector of (SYM,BLOCK) tuples. This newly-allocated
5835 vector should be freed when no longer useful.
5836
4eeaa230
DE
5837 See ada_lookup_symbol_list_worker for further details. */
5838
5839int
b5ec771e 5840ada_lookup_symbol_list (const char *name, const struct block *block,
d12307c1 5841 domain_enum domain, struct block_symbol **results)
4eeaa230 5842{
b5ec771e
PA
5843 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5844 lookup_name_info lookup_name (name, name_match_type);
5845
5846 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5847}
5848
5849/* Implementation of the la_iterate_over_symbols method. */
5850
5851static void
14bc53a8 5852ada_iterate_over_symbols
b5ec771e
PA
5853 (const struct block *block, const lookup_name_info &name,
5854 domain_enum domain,
14bc53a8 5855 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5856{
5857 int ndefs, i;
d12307c1 5858 struct block_symbol *results;
ec6a20c2 5859 struct cleanup *old_chain;
4eeaa230
DE
5860
5861 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2
JB
5862 old_chain = make_cleanup (xfree, results);
5863
4eeaa230
DE
5864 for (i = 0; i < ndefs; ++i)
5865 {
14bc53a8 5866 if (!callback (results[i].symbol))
4eeaa230
DE
5867 break;
5868 }
ec6a20c2
JB
5869
5870 do_cleanups (old_chain);
4eeaa230
DE
5871}
5872
4e5c77fe
JB
5873/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5874 to 1, but choosing the first symbol found if there are multiple
5875 choices.
5876
5e2336be
JB
5877 The result is stored in *INFO, which must be non-NULL.
5878 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5879
5880void
5881ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5882 domain_enum domain,
d12307c1 5883 struct block_symbol *info)
14f9c5c9 5884{
b5ec771e
PA
5885 /* Since we already have an encoded name, wrap it in '<>' to force a
5886 verbatim match. Otherwise, if the name happens to not look like
5887 an encoded name (because it doesn't include a "__"),
5888 ada_lookup_name_info would re-encode/fold it again, and that
5889 would e.g., incorrectly lowercase object renaming names like
5890 "R28b" -> "r28b". */
5891 std::string verbatim = std::string ("<") + name + '>';
5892
5e2336be 5893 gdb_assert (info != NULL);
f98fc17b 5894 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5895}
aeb5907d
JB
5896
5897/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5898 scope and in global scopes, or NULL if none. NAME is folded and
5899 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5900 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5901 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5902
d12307c1 5903struct block_symbol
aeb5907d 5904ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5905 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5906{
5907 if (is_a_field_of_this != NULL)
5908 *is_a_field_of_this = 0;
5909
f98fc17b
PA
5910 struct block_symbol *candidates;
5911 int n_candidates;
5912 struct cleanup *old_chain;
5913
5914 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5915 old_chain = make_cleanup (xfree, candidates);
5916
5917 if (n_candidates == 0)
5918 {
5919 do_cleanups (old_chain);
5920 return {};
5921 }
5922
5923 block_symbol info = candidates[0];
5924 info.symbol = fixup_symbol_section (info.symbol, NULL);
5925
5926 do_cleanups (old_chain);
5927
d12307c1 5928 return info;
4c4b4cd2 5929}
14f9c5c9 5930
d12307c1 5931static struct block_symbol
f606139a
DE
5932ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5933 const char *name,
76a01679 5934 const struct block *block,
21b556f4 5935 const domain_enum domain)
4c4b4cd2 5936{
d12307c1 5937 struct block_symbol sym;
04dccad0
JB
5938
5939 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5940 if (sym.symbol != NULL)
04dccad0
JB
5941 return sym;
5942
5943 /* If we haven't found a match at this point, try the primitive
5944 types. In other languages, this search is performed before
5945 searching for global symbols in order to short-circuit that
5946 global-symbol search if it happens that the name corresponds
5947 to a primitive type. But we cannot do the same in Ada, because
5948 it is perfectly legitimate for a program to declare a type which
5949 has the same name as a standard type. If looking up a type in
5950 that situation, we have traditionally ignored the primitive type
5951 in favor of user-defined types. This is why, unlike most other
5952 languages, we search the primitive types this late and only after
5953 having searched the global symbols without success. */
5954
5955 if (domain == VAR_DOMAIN)
5956 {
5957 struct gdbarch *gdbarch;
5958
5959 if (block == NULL)
5960 gdbarch = target_gdbarch ();
5961 else
5962 gdbarch = block_gdbarch (block);
d12307c1
PMR
5963 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5964 if (sym.symbol != NULL)
04dccad0
JB
5965 return sym;
5966 }
5967
d12307c1 5968 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5969}
5970
5971
4c4b4cd2
PH
5972/* True iff STR is a possible encoded suffix of a normal Ada name
5973 that is to be ignored for matching purposes. Suffixes of parallel
5974 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5975 are given by any of the regular expressions:
4c4b4cd2 5976
babe1480
JB
5977 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5978 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5979 TKB [subprogram suffix for task bodies]
babe1480 5980 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5981 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5982
5983 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5984 match is performed. This sequence is used to differentiate homonyms,
5985 is an optional part of a valid name suffix. */
4c4b4cd2 5986
14f9c5c9 5987static int
d2e4a39e 5988is_name_suffix (const char *str)
14f9c5c9
AS
5989{
5990 int k;
4c4b4cd2
PH
5991 const char *matching;
5992 const int len = strlen (str);
5993
babe1480
JB
5994 /* Skip optional leading __[0-9]+. */
5995
4c4b4cd2
PH
5996 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5997 {
babe1480
JB
5998 str += 3;
5999 while (isdigit (str[0]))
6000 str += 1;
4c4b4cd2 6001 }
babe1480
JB
6002
6003 /* [.$][0-9]+ */
4c4b4cd2 6004
babe1480 6005 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 6006 {
babe1480 6007 matching = str + 1;
4c4b4cd2
PH
6008 while (isdigit (matching[0]))
6009 matching += 1;
6010 if (matching[0] == '\0')
6011 return 1;
6012 }
6013
6014 /* ___[0-9]+ */
babe1480 6015
4c4b4cd2
PH
6016 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6017 {
6018 matching = str + 3;
6019 while (isdigit (matching[0]))
6020 matching += 1;
6021 if (matching[0] == '\0')
6022 return 1;
6023 }
6024
9ac7f98e
JB
6025 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6026
6027 if (strcmp (str, "TKB") == 0)
6028 return 1;
6029
529cad9c
PH
6030#if 0
6031 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
6032 with a N at the end. Unfortunately, the compiler uses the same
6033 convention for other internal types it creates. So treating
529cad9c 6034 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
6035 some regressions. For instance, consider the case of an enumerated
6036 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
6037 name ends with N.
6038 Having a single character like this as a suffix carrying some
0963b4bd 6039 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
6040 to be something like "_N" instead. In the meantime, do not do
6041 the following check. */
6042 /* Protected Object Subprograms */
6043 if (len == 1 && str [0] == 'N')
6044 return 1;
6045#endif
6046
6047 /* _E[0-9]+[bs]$ */
6048 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6049 {
6050 matching = str + 3;
6051 while (isdigit (matching[0]))
6052 matching += 1;
6053 if ((matching[0] == 'b' || matching[0] == 's')
6054 && matching [1] == '\0')
6055 return 1;
6056 }
6057
4c4b4cd2
PH
6058 /* ??? We should not modify STR directly, as we are doing below. This
6059 is fine in this case, but may become problematic later if we find
6060 that this alternative did not work, and want to try matching
6061 another one from the begining of STR. Since we modified it, we
6062 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6063 if (str[0] == 'X')
6064 {
6065 str += 1;
d2e4a39e 6066 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6067 {
6068 if (str[0] != 'n' && str[0] != 'b')
6069 return 0;
6070 str += 1;
6071 }
14f9c5c9 6072 }
babe1480 6073
14f9c5c9
AS
6074 if (str[0] == '\000')
6075 return 1;
babe1480 6076
d2e4a39e 6077 if (str[0] == '_')
14f9c5c9
AS
6078 {
6079 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6080 return 0;
d2e4a39e 6081 if (str[2] == '_')
4c4b4cd2 6082 {
61ee279c
PH
6083 if (strcmp (str + 3, "JM") == 0)
6084 return 1;
6085 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6086 the LJM suffix in favor of the JM one. But we will
6087 still accept LJM as a valid suffix for a reasonable
6088 amount of time, just to allow ourselves to debug programs
6089 compiled using an older version of GNAT. */
4c4b4cd2
PH
6090 if (strcmp (str + 3, "LJM") == 0)
6091 return 1;
6092 if (str[3] != 'X')
6093 return 0;
1265e4aa
JB
6094 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6095 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6096 return 1;
6097 if (str[4] == 'R' && str[5] != 'T')
6098 return 1;
6099 return 0;
6100 }
6101 if (!isdigit (str[2]))
6102 return 0;
6103 for (k = 3; str[k] != '\0'; k += 1)
6104 if (!isdigit (str[k]) && str[k] != '_')
6105 return 0;
14f9c5c9
AS
6106 return 1;
6107 }
4c4b4cd2 6108 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6109 {
4c4b4cd2
PH
6110 for (k = 2; str[k] != '\0'; k += 1)
6111 if (!isdigit (str[k]) && str[k] != '_')
6112 return 0;
14f9c5c9
AS
6113 return 1;
6114 }
6115 return 0;
6116}
d2e4a39e 6117
aeb5907d
JB
6118/* Return non-zero if the string starting at NAME and ending before
6119 NAME_END contains no capital letters. */
529cad9c
PH
6120
6121static int
6122is_valid_name_for_wild_match (const char *name0)
6123{
6124 const char *decoded_name = ada_decode (name0);
6125 int i;
6126
5823c3ef
JB
6127 /* If the decoded name starts with an angle bracket, it means that
6128 NAME0 does not follow the GNAT encoding format. It should then
6129 not be allowed as a possible wild match. */
6130 if (decoded_name[0] == '<')
6131 return 0;
6132
529cad9c
PH
6133 for (i=0; decoded_name[i] != '\0'; i++)
6134 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6135 return 0;
6136
6137 return 1;
6138}
6139
73589123
PH
6140/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6141 that could start a simple name. Assumes that *NAMEP points into
6142 the string beginning at NAME0. */
4c4b4cd2 6143
14f9c5c9 6144static int
73589123 6145advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6146{
73589123 6147 const char *name = *namep;
5b4ee69b 6148
5823c3ef 6149 while (1)
14f9c5c9 6150 {
aa27d0b3 6151 int t0, t1;
73589123
PH
6152
6153 t0 = *name;
6154 if (t0 == '_')
6155 {
6156 t1 = name[1];
6157 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6158 {
6159 name += 1;
61012eef 6160 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6161 break;
6162 else
6163 name += 1;
6164 }
aa27d0b3
JB
6165 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6166 || name[2] == target0))
73589123
PH
6167 {
6168 name += 2;
6169 break;
6170 }
6171 else
6172 return 0;
6173 }
6174 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6175 name += 1;
6176 else
5823c3ef 6177 return 0;
73589123
PH
6178 }
6179
6180 *namep = name;
6181 return 1;
6182}
6183
b5ec771e
PA
6184/* Return true iff NAME encodes a name of the form prefix.PATN.
6185 Ignores any informational suffixes of NAME (i.e., for which
6186 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6187 simple name. */
73589123 6188
b5ec771e 6189static bool
73589123
PH
6190wild_match (const char *name, const char *patn)
6191{
22e048c9 6192 const char *p;
73589123
PH
6193 const char *name0 = name;
6194
6195 while (1)
6196 {
6197 const char *match = name;
6198
6199 if (*name == *patn)
6200 {
6201 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6202 if (*p != *name)
6203 break;
6204 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6205 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6206
6207 if (name[-1] == '_')
6208 name -= 1;
6209 }
6210 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6211 return false;
96d887e8 6212 }
96d887e8
PH
6213}
6214
b5ec771e
PA
6215/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6216 any trailing suffixes that encode debugging information or leading
6217 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6218 information that is ignored). */
40658b94 6219
b5ec771e 6220static bool
c4d840bd
PH
6221full_match (const char *sym_name, const char *search_name)
6222{
b5ec771e
PA
6223 size_t search_name_len = strlen (search_name);
6224
6225 if (strncmp (sym_name, search_name, search_name_len) == 0
6226 && is_name_suffix (sym_name + search_name_len))
6227 return true;
6228
6229 if (startswith (sym_name, "_ada_")
6230 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6231 && is_name_suffix (sym_name + search_name_len + 5))
6232 return true;
c4d840bd 6233
b5ec771e
PA
6234 return false;
6235}
c4d840bd 6236
b5ec771e
PA
6237/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6238 *defn_symbols, updating the list of symbols in OBSTACKP (if
6239 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6240
6241static void
6242ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6243 const struct block *block,
6244 const lookup_name_info &lookup_name,
6245 domain_enum domain, struct objfile *objfile)
96d887e8 6246{
8157b174 6247 struct block_iterator iter;
96d887e8
PH
6248 /* A matching argument symbol, if any. */
6249 struct symbol *arg_sym;
6250 /* Set true when we find a matching non-argument symbol. */
6251 int found_sym;
6252 struct symbol *sym;
6253
6254 arg_sym = NULL;
6255 found_sym = 0;
b5ec771e
PA
6256 for (sym = block_iter_match_first (block, lookup_name, &iter);
6257 sym != NULL;
6258 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6259 {
b5ec771e
PA
6260 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6261 SYMBOL_DOMAIN (sym), domain))
6262 {
6263 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6264 {
6265 if (SYMBOL_IS_ARGUMENT (sym))
6266 arg_sym = sym;
6267 else
6268 {
6269 found_sym = 1;
6270 add_defn_to_vec (obstackp,
6271 fixup_symbol_section (sym, objfile),
6272 block);
6273 }
6274 }
6275 }
96d887e8
PH
6276 }
6277
22cee43f
PMR
6278 /* Handle renamings. */
6279
b5ec771e 6280 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6281 found_sym = 1;
6282
96d887e8
PH
6283 if (!found_sym && arg_sym != NULL)
6284 {
76a01679
JB
6285 add_defn_to_vec (obstackp,
6286 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6287 block);
96d887e8
PH
6288 }
6289
b5ec771e 6290 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6291 {
6292 arg_sym = NULL;
6293 found_sym = 0;
b5ec771e
PA
6294 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6295 const char *name = ada_lookup_name.c_str ();
6296 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6297
6298 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6299 {
4186eb54
KS
6300 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6301 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6302 {
6303 int cmp;
6304
6305 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6306 if (cmp == 0)
6307 {
61012eef 6308 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6309 if (cmp == 0)
6310 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6311 name_len);
6312 }
6313
6314 if (cmp == 0
6315 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6316 {
2a2d4dc3
AS
6317 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6318 {
6319 if (SYMBOL_IS_ARGUMENT (sym))
6320 arg_sym = sym;
6321 else
6322 {
6323 found_sym = 1;
6324 add_defn_to_vec (obstackp,
6325 fixup_symbol_section (sym, objfile),
6326 block);
6327 }
6328 }
76a01679
JB
6329 }
6330 }
76a01679 6331 }
96d887e8
PH
6332
6333 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6334 They aren't parameters, right? */
6335 if (!found_sym && arg_sym != NULL)
6336 {
6337 add_defn_to_vec (obstackp,
76a01679 6338 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6339 block);
96d887e8
PH
6340 }
6341 }
6342}
6343\f
41d27058
JB
6344
6345 /* Symbol Completion */
6346
b5ec771e 6347/* See symtab.h. */
41d27058 6348
b5ec771e
PA
6349bool
6350ada_lookup_name_info::matches
6351 (const char *sym_name,
6352 symbol_name_match_type match_type,
a207cff2 6353 completion_match_result *comp_match_res) const
41d27058 6354{
b5ec771e
PA
6355 bool match = false;
6356 const char *text = m_encoded_name.c_str ();
6357 size_t text_len = m_encoded_name.size ();
41d27058
JB
6358
6359 /* First, test against the fully qualified name of the symbol. */
6360
6361 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6362 match = true;
41d27058 6363
b5ec771e 6364 if (match && !m_encoded_p)
41d27058
JB
6365 {
6366 /* One needed check before declaring a positive match is to verify
6367 that iff we are doing a verbatim match, the decoded version
6368 of the symbol name starts with '<'. Otherwise, this symbol name
6369 is not a suitable completion. */
6370 const char *sym_name_copy = sym_name;
b5ec771e 6371 bool has_angle_bracket;
41d27058
JB
6372
6373 sym_name = ada_decode (sym_name);
6374 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6375 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6376 sym_name = sym_name_copy;
6377 }
6378
b5ec771e 6379 if (match && !m_verbatim_p)
41d27058
JB
6380 {
6381 /* When doing non-verbatim match, another check that needs to
6382 be done is to verify that the potentially matching symbol name
6383 does not include capital letters, because the ada-mode would
6384 not be able to understand these symbol names without the
6385 angle bracket notation. */
6386 const char *tmp;
6387
6388 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6389 if (*tmp != '\0')
b5ec771e 6390 match = false;
41d27058
JB
6391 }
6392
6393 /* Second: Try wild matching... */
6394
b5ec771e 6395 if (!match && m_wild_match_p)
41d27058
JB
6396 {
6397 /* Since we are doing wild matching, this means that TEXT
6398 may represent an unqualified symbol name. We therefore must
6399 also compare TEXT against the unqualified name of the symbol. */
6400 sym_name = ada_unqualified_name (ada_decode (sym_name));
6401
6402 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6403 match = true;
41d27058
JB
6404 }
6405
b5ec771e 6406 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6407
6408 if (!match)
b5ec771e 6409 return false;
41d27058 6410
a207cff2 6411 if (comp_match_res != NULL)
b5ec771e 6412 {
a207cff2 6413 std::string &match_str = comp_match_res->match.storage ();
41d27058 6414
b5ec771e 6415 if (!m_encoded_p)
a207cff2 6416 match_str = ada_decode (sym_name);
b5ec771e
PA
6417 else
6418 {
6419 if (m_verbatim_p)
6420 match_str = add_angle_brackets (sym_name);
6421 else
6422 match_str = sym_name;
41d27058 6423
b5ec771e 6424 }
a207cff2
PA
6425
6426 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6427 }
6428
b5ec771e 6429 return true;
41d27058
JB
6430}
6431
b5ec771e 6432/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6433 WORD is the entire command on which completion is made. */
41d27058 6434
eb3ff9a5
PA
6435static void
6436ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6437 complete_symbol_mode mode,
b5ec771e
PA
6438 symbol_name_match_type name_match_type,
6439 const char *text, const char *word,
eb3ff9a5 6440 enum type_code code)
41d27058 6441{
41d27058 6442 struct symbol *sym;
43f3e411 6443 struct compunit_symtab *s;
41d27058
JB
6444 struct minimal_symbol *msymbol;
6445 struct objfile *objfile;
3977b71f 6446 const struct block *b, *surrounding_static_block = 0;
8157b174 6447 struct block_iterator iter;
b8fea896 6448 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6449
2f68a895
TT
6450 gdb_assert (code == TYPE_CODE_UNDEF);
6451
1b026119 6452 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6453
6454 /* First, look at the partial symtab symbols. */
14bc53a8 6455 expand_symtabs_matching (NULL,
b5ec771e
PA
6456 lookup_name,
6457 NULL,
14bc53a8
PA
6458 NULL,
6459 ALL_DOMAIN);
41d27058
JB
6460
6461 /* At this point scan through the misc symbol vectors and add each
6462 symbol you find to the list. Eventually we want to ignore
6463 anything that isn't a text symbol (everything else will be
6464 handled by the psymtab code above). */
6465
6466 ALL_MSYMBOLS (objfile, msymbol)
6467 {
6468 QUIT;
b5ec771e 6469
f9d67a22
PA
6470 if (completion_skip_symbol (mode, msymbol))
6471 continue;
6472
d4c2a405
PA
6473 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6474
6475 /* Ada minimal symbols won't have their language set to Ada. If
6476 we let completion_list_add_name compare using the
6477 default/C-like matcher, then when completing e.g., symbols in a
6478 package named "pck", we'd match internal Ada symbols like
6479 "pckS", which are invalid in an Ada expression, unless you wrap
6480 them in '<' '>' to request a verbatim match.
6481
6482 Unfortunately, some Ada encoded names successfully demangle as
6483 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6484 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6485 with the wrong language set. Paper over that issue here. */
6486 if (symbol_language == language_auto
6487 || symbol_language == language_cplus)
6488 symbol_language = language_ada;
6489
b5ec771e 6490 completion_list_add_name (tracker,
d4c2a405 6491 symbol_language,
b5ec771e 6492 MSYMBOL_LINKAGE_NAME (msymbol),
1b026119 6493 lookup_name, text, word);
41d27058
JB
6494 }
6495
6496 /* Search upwards from currently selected frame (so that we can
6497 complete on local vars. */
6498
6499 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6500 {
6501 if (!BLOCK_SUPERBLOCK (b))
6502 surrounding_static_block = b; /* For elmin of dups */
6503
6504 ALL_BLOCK_SYMBOLS (b, iter, sym)
6505 {
f9d67a22
PA
6506 if (completion_skip_symbol (mode, sym))
6507 continue;
6508
b5ec771e
PA
6509 completion_list_add_name (tracker,
6510 SYMBOL_LANGUAGE (sym),
6511 SYMBOL_LINKAGE_NAME (sym),
1b026119 6512 lookup_name, text, word);
41d27058
JB
6513 }
6514 }
6515
6516 /* Go through the symtabs and check the externs and statics for
43f3e411 6517 symbols which match. */
41d27058 6518
43f3e411 6519 ALL_COMPUNITS (objfile, s)
41d27058
JB
6520 {
6521 QUIT;
43f3e411 6522 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6523 ALL_BLOCK_SYMBOLS (b, iter, sym)
6524 {
f9d67a22
PA
6525 if (completion_skip_symbol (mode, sym))
6526 continue;
6527
b5ec771e
PA
6528 completion_list_add_name (tracker,
6529 SYMBOL_LANGUAGE (sym),
6530 SYMBOL_LINKAGE_NAME (sym),
1b026119 6531 lookup_name, text, word);
41d27058
JB
6532 }
6533 }
6534
43f3e411 6535 ALL_COMPUNITS (objfile, s)
41d27058
JB
6536 {
6537 QUIT;
43f3e411 6538 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6539 /* Don't do this block twice. */
6540 if (b == surrounding_static_block)
6541 continue;
6542 ALL_BLOCK_SYMBOLS (b, iter, sym)
6543 {
f9d67a22
PA
6544 if (completion_skip_symbol (mode, sym))
6545 continue;
6546
b5ec771e
PA
6547 completion_list_add_name (tracker,
6548 SYMBOL_LANGUAGE (sym),
6549 SYMBOL_LINKAGE_NAME (sym),
1b026119 6550 lookup_name, text, word);
41d27058
JB
6551 }
6552 }
6553
b8fea896 6554 do_cleanups (old_chain);
41d27058
JB
6555}
6556
963a6417 6557 /* Field Access */
96d887e8 6558
73fb9985
JB
6559/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6560 for tagged types. */
6561
6562static int
6563ada_is_dispatch_table_ptr_type (struct type *type)
6564{
0d5cff50 6565 const char *name;
73fb9985
JB
6566
6567 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6568 return 0;
6569
6570 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6571 if (name == NULL)
6572 return 0;
6573
6574 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6575}
6576
ac4a2da4
JG
6577/* Return non-zero if TYPE is an interface tag. */
6578
6579static int
6580ada_is_interface_tag (struct type *type)
6581{
6582 const char *name = TYPE_NAME (type);
6583
6584 if (name == NULL)
6585 return 0;
6586
6587 return (strcmp (name, "ada__tags__interface_tag") == 0);
6588}
6589
963a6417
PH
6590/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6591 to be invisible to users. */
96d887e8 6592
963a6417
PH
6593int
6594ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6595{
963a6417
PH
6596 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6597 return 1;
ffde82bf 6598
73fb9985
JB
6599 /* Check the name of that field. */
6600 {
6601 const char *name = TYPE_FIELD_NAME (type, field_num);
6602
6603 /* Anonymous field names should not be printed.
6604 brobecker/2007-02-20: I don't think this can actually happen
6605 but we don't want to print the value of annonymous fields anyway. */
6606 if (name == NULL)
6607 return 1;
6608
ffde82bf
JB
6609 /* Normally, fields whose name start with an underscore ("_")
6610 are fields that have been internally generated by the compiler,
6611 and thus should not be printed. The "_parent" field is special,
6612 however: This is a field internally generated by the compiler
6613 for tagged types, and it contains the components inherited from
6614 the parent type. This field should not be printed as is, but
6615 should not be ignored either. */
61012eef 6616 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6617 return 1;
6618 }
6619
ac4a2da4
JG
6620 /* If this is the dispatch table of a tagged type or an interface tag,
6621 then ignore. */
73fb9985 6622 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6623 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6624 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6625 return 1;
6626
6627 /* Not a special field, so it should not be ignored. */
6628 return 0;
963a6417 6629}
96d887e8 6630
963a6417 6631/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6632 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6633
963a6417
PH
6634int
6635ada_is_tagged_type (struct type *type, int refok)
6636{
988f6b3d 6637 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6638}
96d887e8 6639
963a6417 6640/* True iff TYPE represents the type of X'Tag */
96d887e8 6641
963a6417
PH
6642int
6643ada_is_tag_type (struct type *type)
6644{
460efde1
JB
6645 type = ada_check_typedef (type);
6646
963a6417
PH
6647 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6648 return 0;
6649 else
96d887e8 6650 {
963a6417 6651 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6652
963a6417
PH
6653 return (name != NULL
6654 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6655 }
96d887e8
PH
6656}
6657
963a6417 6658/* The type of the tag on VAL. */
76a01679 6659
963a6417
PH
6660struct type *
6661ada_tag_type (struct value *val)
96d887e8 6662{
988f6b3d 6663 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6664}
96d887e8 6665
b50d69b5
JG
6666/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6667 retired at Ada 05). */
6668
6669static int
6670is_ada95_tag (struct value *tag)
6671{
6672 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6673}
6674
963a6417 6675/* The value of the tag on VAL. */
96d887e8 6676
963a6417
PH
6677struct value *
6678ada_value_tag (struct value *val)
6679{
03ee6b2e 6680 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6681}
6682
963a6417
PH
6683/* The value of the tag on the object of type TYPE whose contents are
6684 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6685 ADDRESS. */
96d887e8 6686
963a6417 6687static struct value *
10a2c479 6688value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6689 const gdb_byte *valaddr,
963a6417 6690 CORE_ADDR address)
96d887e8 6691{
b5385fc0 6692 int tag_byte_offset;
963a6417 6693 struct type *tag_type;
5b4ee69b 6694
963a6417 6695 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6696 NULL, NULL, NULL))
96d887e8 6697 {
fc1a4b47 6698 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6699 ? NULL
6700 : valaddr + tag_byte_offset);
963a6417 6701 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6702
963a6417 6703 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6704 }
963a6417
PH
6705 return NULL;
6706}
96d887e8 6707
963a6417
PH
6708static struct type *
6709type_from_tag (struct value *tag)
6710{
6711 const char *type_name = ada_tag_name (tag);
5b4ee69b 6712
963a6417
PH
6713 if (type_name != NULL)
6714 return ada_find_any_type (ada_encode (type_name));
6715 return NULL;
6716}
96d887e8 6717
b50d69b5
JG
6718/* Given a value OBJ of a tagged type, return a value of this
6719 type at the base address of the object. The base address, as
6720 defined in Ada.Tags, it is the address of the primary tag of
6721 the object, and therefore where the field values of its full
6722 view can be fetched. */
6723
6724struct value *
6725ada_tag_value_at_base_address (struct value *obj)
6726{
b50d69b5
JG
6727 struct value *val;
6728 LONGEST offset_to_top = 0;
6729 struct type *ptr_type, *obj_type;
6730 struct value *tag;
6731 CORE_ADDR base_address;
6732
6733 obj_type = value_type (obj);
6734
6735 /* It is the responsability of the caller to deref pointers. */
6736
6737 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6738 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6739 return obj;
6740
6741 tag = ada_value_tag (obj);
6742 if (!tag)
6743 return obj;
6744
6745 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6746
6747 if (is_ada95_tag (tag))
6748 return obj;
6749
08f49010
XR
6750 ptr_type = language_lookup_primitive_type
6751 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6752 ptr_type = lookup_pointer_type (ptr_type);
6753 val = value_cast (ptr_type, tag);
6754 if (!val)
6755 return obj;
6756
6757 /* It is perfectly possible that an exception be raised while
6758 trying to determine the base address, just like for the tag;
6759 see ada_tag_name for more details. We do not print the error
6760 message for the same reason. */
6761
492d29ea 6762 TRY
b50d69b5
JG
6763 {
6764 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6765 }
6766
492d29ea
PA
6767 CATCH (e, RETURN_MASK_ERROR)
6768 {
6769 return obj;
6770 }
6771 END_CATCH
b50d69b5
JG
6772
6773 /* If offset is null, nothing to do. */
6774
6775 if (offset_to_top == 0)
6776 return obj;
6777
6778 /* -1 is a special case in Ada.Tags; however, what should be done
6779 is not quite clear from the documentation. So do nothing for
6780 now. */
6781
6782 if (offset_to_top == -1)
6783 return obj;
6784
08f49010
XR
6785 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6786 from the base address. This was however incompatible with
6787 C++ dispatch table: C++ uses a *negative* value to *add*
6788 to the base address. Ada's convention has therefore been
6789 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6790 use the same convention. Here, we support both cases by
6791 checking the sign of OFFSET_TO_TOP. */
6792
6793 if (offset_to_top > 0)
6794 offset_to_top = -offset_to_top;
6795
6796 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6797 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6798
6799 /* Make sure that we have a proper tag at the new address.
6800 Otherwise, offset_to_top is bogus (which can happen when
6801 the object is not initialized yet). */
6802
6803 if (!tag)
6804 return obj;
6805
6806 obj_type = type_from_tag (tag);
6807
6808 if (!obj_type)
6809 return obj;
6810
6811 return value_from_contents_and_address (obj_type, NULL, base_address);
6812}
6813
1b611343
JB
6814/* Return the "ada__tags__type_specific_data" type. */
6815
6816static struct type *
6817ada_get_tsd_type (struct inferior *inf)
963a6417 6818{
1b611343 6819 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6820
1b611343
JB
6821 if (data->tsd_type == 0)
6822 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6823 return data->tsd_type;
6824}
529cad9c 6825
1b611343
JB
6826/* Return the TSD (type-specific data) associated to the given TAG.
6827 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6828
1b611343 6829 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6830
1b611343
JB
6831static struct value *
6832ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6833{
4c4b4cd2 6834 struct value *val;
1b611343 6835 struct type *type;
5b4ee69b 6836
1b611343
JB
6837 /* First option: The TSD is simply stored as a field of our TAG.
6838 Only older versions of GNAT would use this format, but we have
6839 to test it first, because there are no visible markers for
6840 the current approach except the absence of that field. */
529cad9c 6841
1b611343
JB
6842 val = ada_value_struct_elt (tag, "tsd", 1);
6843 if (val)
6844 return val;
e802dbe0 6845
1b611343
JB
6846 /* Try the second representation for the dispatch table (in which
6847 there is no explicit 'tsd' field in the referent of the tag pointer,
6848 and instead the tsd pointer is stored just before the dispatch
6849 table. */
e802dbe0 6850
1b611343
JB
6851 type = ada_get_tsd_type (current_inferior());
6852 if (type == NULL)
6853 return NULL;
6854 type = lookup_pointer_type (lookup_pointer_type (type));
6855 val = value_cast (type, tag);
6856 if (val == NULL)
6857 return NULL;
6858 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6859}
6860
1b611343
JB
6861/* Given the TSD of a tag (type-specific data), return a string
6862 containing the name of the associated type.
6863
6864 The returned value is good until the next call. May return NULL
6865 if we are unable to determine the tag name. */
6866
6867static char *
6868ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6869{
529cad9c
PH
6870 static char name[1024];
6871 char *p;
1b611343 6872 struct value *val;
529cad9c 6873
1b611343 6874 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6875 if (val == NULL)
1b611343 6876 return NULL;
4c4b4cd2
PH
6877 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6878 for (p = name; *p != '\0'; p += 1)
6879 if (isalpha (*p))
6880 *p = tolower (*p);
1b611343 6881 return name;
4c4b4cd2
PH
6882}
6883
6884/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6885 a C string.
6886
6887 Return NULL if the TAG is not an Ada tag, or if we were unable to
6888 determine the name of that tag. The result is good until the next
6889 call. */
4c4b4cd2
PH
6890
6891const char *
6892ada_tag_name (struct value *tag)
6893{
1b611343 6894 char *name = NULL;
5b4ee69b 6895
df407dfe 6896 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6897 return NULL;
1b611343
JB
6898
6899 /* It is perfectly possible that an exception be raised while trying
6900 to determine the TAG's name, even under normal circumstances:
6901 The associated variable may be uninitialized or corrupted, for
6902 instance. We do not let any exception propagate past this point.
6903 instead we return NULL.
6904
6905 We also do not print the error message either (which often is very
6906 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6907 the caller print a more meaningful message if necessary. */
492d29ea 6908 TRY
1b611343
JB
6909 {
6910 struct value *tsd = ada_get_tsd_from_tag (tag);
6911
6912 if (tsd != NULL)
6913 name = ada_tag_name_from_tsd (tsd);
6914 }
492d29ea
PA
6915 CATCH (e, RETURN_MASK_ERROR)
6916 {
6917 }
6918 END_CATCH
1b611343
JB
6919
6920 return name;
4c4b4cd2
PH
6921}
6922
6923/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6924
d2e4a39e 6925struct type *
ebf56fd3 6926ada_parent_type (struct type *type)
14f9c5c9
AS
6927{
6928 int i;
6929
61ee279c 6930 type = ada_check_typedef (type);
14f9c5c9
AS
6931
6932 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6933 return NULL;
6934
6935 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6936 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6937 {
6938 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6939
6940 /* If the _parent field is a pointer, then dereference it. */
6941 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6942 parent_type = TYPE_TARGET_TYPE (parent_type);
6943 /* If there is a parallel XVS type, get the actual base type. */
6944 parent_type = ada_get_base_type (parent_type);
6945
6946 return ada_check_typedef (parent_type);
6947 }
14f9c5c9
AS
6948
6949 return NULL;
6950}
6951
4c4b4cd2
PH
6952/* True iff field number FIELD_NUM of structure type TYPE contains the
6953 parent-type (inherited) fields of a derived type. Assumes TYPE is
6954 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6955
6956int
ebf56fd3 6957ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6958{
61ee279c 6959 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6960
4c4b4cd2 6961 return (name != NULL
61012eef
GB
6962 && (startswith (name, "PARENT")
6963 || startswith (name, "_parent")));
14f9c5c9
AS
6964}
6965
4c4b4cd2 6966/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6967 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6968 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6969 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6970 structures. */
14f9c5c9
AS
6971
6972int
ebf56fd3 6973ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6974{
d2e4a39e 6975 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6976
dddc0e16
JB
6977 if (name != NULL && strcmp (name, "RETVAL") == 0)
6978 {
6979 /* This happens in functions with "out" or "in out" parameters
6980 which are passed by copy. For such functions, GNAT describes
6981 the function's return type as being a struct where the return
6982 value is in a field called RETVAL, and where the other "out"
6983 or "in out" parameters are fields of that struct. This is not
6984 a wrapper. */
6985 return 0;
6986 }
6987
d2e4a39e 6988 return (name != NULL
61012eef 6989 && (startswith (name, "PARENT")
4c4b4cd2 6990 || strcmp (name, "REP") == 0
61012eef 6991 || startswith (name, "_parent")
4c4b4cd2 6992 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6993}
6994
4c4b4cd2
PH
6995/* True iff field number FIELD_NUM of structure or union type TYPE
6996 is a variant wrapper. Assumes TYPE is a structure type with at least
6997 FIELD_NUM+1 fields. */
14f9c5c9
AS
6998
6999int
ebf56fd3 7000ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 7001{
d2e4a39e 7002 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 7003
14f9c5c9 7004 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 7005 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
7006 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
7007 == TYPE_CODE_UNION)));
14f9c5c9
AS
7008}
7009
7010/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 7011 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
7012 returns the type of the controlling discriminant for the variant.
7013 May return NULL if the type could not be found. */
14f9c5c9 7014
d2e4a39e 7015struct type *
ebf56fd3 7016ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 7017{
a121b7c1 7018 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 7019
988f6b3d 7020 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
7021}
7022
4c4b4cd2 7023/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 7024 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 7025 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
7026
7027int
ebf56fd3 7028ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 7029{
d2e4a39e 7030 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 7031
14f9c5c9
AS
7032 return (name != NULL && name[0] == 'O');
7033}
7034
7035/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
7036 returns the name of the discriminant controlling the variant.
7037 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 7038
a121b7c1 7039const char *
ebf56fd3 7040ada_variant_discrim_name (struct type *type0)
14f9c5c9 7041{
d2e4a39e 7042 static char *result = NULL;
14f9c5c9 7043 static size_t result_len = 0;
d2e4a39e
AS
7044 struct type *type;
7045 const char *name;
7046 const char *discrim_end;
7047 const char *discrim_start;
14f9c5c9
AS
7048
7049 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7050 type = TYPE_TARGET_TYPE (type0);
7051 else
7052 type = type0;
7053
7054 name = ada_type_name (type);
7055
7056 if (name == NULL || name[0] == '\000')
7057 return "";
7058
7059 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7060 discrim_end -= 1)
7061 {
61012eef 7062 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7063 break;
14f9c5c9
AS
7064 }
7065 if (discrim_end == name)
7066 return "";
7067
d2e4a39e 7068 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7069 discrim_start -= 1)
7070 {
d2e4a39e 7071 if (discrim_start == name + 1)
4c4b4cd2 7072 return "";
76a01679 7073 if ((discrim_start > name + 3
61012eef 7074 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7075 || discrim_start[-1] == '.')
7076 break;
14f9c5c9
AS
7077 }
7078
7079 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7080 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7081 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7082 return result;
7083}
7084
4c4b4cd2
PH
7085/* Scan STR for a subtype-encoded number, beginning at position K.
7086 Put the position of the character just past the number scanned in
7087 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7088 Return 1 if there was a valid number at the given position, and 0
7089 otherwise. A "subtype-encoded" number consists of the absolute value
7090 in decimal, followed by the letter 'm' to indicate a negative number.
7091 Assumes 0m does not occur. */
14f9c5c9
AS
7092
7093int
d2e4a39e 7094ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7095{
7096 ULONGEST RU;
7097
d2e4a39e 7098 if (!isdigit (str[k]))
14f9c5c9
AS
7099 return 0;
7100
4c4b4cd2 7101 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7102 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7103 LONGEST. */
14f9c5c9
AS
7104 RU = 0;
7105 while (isdigit (str[k]))
7106 {
d2e4a39e 7107 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7108 k += 1;
7109 }
7110
d2e4a39e 7111 if (str[k] == 'm')
14f9c5c9
AS
7112 {
7113 if (R != NULL)
4c4b4cd2 7114 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7115 k += 1;
7116 }
7117 else if (R != NULL)
7118 *R = (LONGEST) RU;
7119
4c4b4cd2 7120 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7121 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7122 number representable as a LONGEST (although either would probably work
7123 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7124 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7125
7126 if (new_k != NULL)
7127 *new_k = k;
7128 return 1;
7129}
7130
4c4b4cd2
PH
7131/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7132 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7133 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7134
d2e4a39e 7135int
ebf56fd3 7136ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7137{
d2e4a39e 7138 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7139 int p;
7140
7141 p = 0;
7142 while (1)
7143 {
d2e4a39e 7144 switch (name[p])
4c4b4cd2
PH
7145 {
7146 case '\0':
7147 return 0;
7148 case 'S':
7149 {
7150 LONGEST W;
5b4ee69b 7151
4c4b4cd2
PH
7152 if (!ada_scan_number (name, p + 1, &W, &p))
7153 return 0;
7154 if (val == W)
7155 return 1;
7156 break;
7157 }
7158 case 'R':
7159 {
7160 LONGEST L, U;
5b4ee69b 7161
4c4b4cd2
PH
7162 if (!ada_scan_number (name, p + 1, &L, &p)
7163 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7164 return 0;
7165 if (val >= L && val <= U)
7166 return 1;
7167 break;
7168 }
7169 case 'O':
7170 return 1;
7171 default:
7172 return 0;
7173 }
7174 }
7175}
7176
0963b4bd 7177/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7178
7179/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7180 ARG_TYPE, extract and return the value of one of its (non-static)
7181 fields. FIELDNO says which field. Differs from value_primitive_field
7182 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7183
4c4b4cd2 7184static struct value *
d2e4a39e 7185ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7186 struct type *arg_type)
14f9c5c9 7187{
14f9c5c9
AS
7188 struct type *type;
7189
61ee279c 7190 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7191 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7192
4c4b4cd2 7193 /* Handle packed fields. */
14f9c5c9
AS
7194
7195 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7196 {
7197 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7198 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7199
0fd88904 7200 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7201 offset + bit_pos / 8,
7202 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7203 }
7204 else
7205 return value_primitive_field (arg1, offset, fieldno, arg_type);
7206}
7207
52ce6436
PH
7208/* Find field with name NAME in object of type TYPE. If found,
7209 set the following for each argument that is non-null:
7210 - *FIELD_TYPE_P to the field's type;
7211 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7212 an object of that type;
7213 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7214 - *BIT_SIZE_P to its size in bits if the field is packed, and
7215 0 otherwise;
7216 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7217 fields up to but not including the desired field, or by the total
7218 number of fields if not found. A NULL value of NAME never
7219 matches; the function just counts visible fields in this case.
7220
828d5846
XR
7221 Notice that we need to handle when a tagged record hierarchy
7222 has some components with the same name, like in this scenario:
7223
7224 type Top_T is tagged record
7225 N : Integer := 1;
7226 U : Integer := 974;
7227 A : Integer := 48;
7228 end record;
7229
7230 type Middle_T is new Top.Top_T with record
7231 N : Character := 'a';
7232 C : Integer := 3;
7233 end record;
7234
7235 type Bottom_T is new Middle.Middle_T with record
7236 N : Float := 4.0;
7237 C : Character := '5';
7238 X : Integer := 6;
7239 A : Character := 'J';
7240 end record;
7241
7242 Let's say we now have a variable declared and initialized as follow:
7243
7244 TC : Top_A := new Bottom_T;
7245
7246 And then we use this variable to call this function
7247
7248 procedure Assign (Obj: in out Top_T; TV : Integer);
7249
7250 as follow:
7251
7252 Assign (Top_T (B), 12);
7253
7254 Now, we're in the debugger, and we're inside that procedure
7255 then and we want to print the value of obj.c:
7256
7257 Usually, the tagged record or one of the parent type owns the
7258 component to print and there's no issue but in this particular
7259 case, what does it mean to ask for Obj.C? Since the actual
7260 type for object is type Bottom_T, it could mean two things: type
7261 component C from the Middle_T view, but also component C from
7262 Bottom_T. So in that "undefined" case, when the component is
7263 not found in the non-resolved type (which includes all the
7264 components of the parent type), then resolve it and see if we
7265 get better luck once expanded.
7266
7267 In the case of homonyms in the derived tagged type, we don't
7268 guaranty anything, and pick the one that's easiest for us
7269 to program.
7270
0963b4bd 7271 Returns 1 if found, 0 otherwise. */
52ce6436 7272
4c4b4cd2 7273static int
0d5cff50 7274find_struct_field (const char *name, struct type *type, int offset,
76a01679 7275 struct type **field_type_p,
52ce6436
PH
7276 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7277 int *index_p)
4c4b4cd2
PH
7278{
7279 int i;
828d5846 7280 int parent_offset = -1;
4c4b4cd2 7281
61ee279c 7282 type = ada_check_typedef (type);
76a01679 7283
52ce6436
PH
7284 if (field_type_p != NULL)
7285 *field_type_p = NULL;
7286 if (byte_offset_p != NULL)
d5d6fca5 7287 *byte_offset_p = 0;
52ce6436
PH
7288 if (bit_offset_p != NULL)
7289 *bit_offset_p = 0;
7290 if (bit_size_p != NULL)
7291 *bit_size_p = 0;
7292
7293 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7294 {
7295 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7296 int fld_offset = offset + bit_pos / 8;
0d5cff50 7297 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7298
4c4b4cd2
PH
7299 if (t_field_name == NULL)
7300 continue;
7301
828d5846
XR
7302 else if (ada_is_parent_field (type, i))
7303 {
7304 /* This is a field pointing us to the parent type of a tagged
7305 type. As hinted in this function's documentation, we give
7306 preference to fields in the current record first, so what
7307 we do here is just record the index of this field before
7308 we skip it. If it turns out we couldn't find our field
7309 in the current record, then we'll get back to it and search
7310 inside it whether the field might exist in the parent. */
7311
7312 parent_offset = i;
7313 continue;
7314 }
7315
52ce6436 7316 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7317 {
7318 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7319
52ce6436
PH
7320 if (field_type_p != NULL)
7321 *field_type_p = TYPE_FIELD_TYPE (type, i);
7322 if (byte_offset_p != NULL)
7323 *byte_offset_p = fld_offset;
7324 if (bit_offset_p != NULL)
7325 *bit_offset_p = bit_pos % 8;
7326 if (bit_size_p != NULL)
7327 *bit_size_p = bit_size;
76a01679
JB
7328 return 1;
7329 }
4c4b4cd2
PH
7330 else if (ada_is_wrapper_field (type, i))
7331 {
52ce6436
PH
7332 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7333 field_type_p, byte_offset_p, bit_offset_p,
7334 bit_size_p, index_p))
76a01679
JB
7335 return 1;
7336 }
4c4b4cd2
PH
7337 else if (ada_is_variant_part (type, i))
7338 {
52ce6436
PH
7339 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7340 fixed type?? */
4c4b4cd2 7341 int j;
52ce6436
PH
7342 struct type *field_type
7343 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7344
52ce6436 7345 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7346 {
76a01679
JB
7347 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7348 fld_offset
7349 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7350 field_type_p, byte_offset_p,
52ce6436 7351 bit_offset_p, bit_size_p, index_p))
76a01679 7352 return 1;
4c4b4cd2
PH
7353 }
7354 }
52ce6436
PH
7355 else if (index_p != NULL)
7356 *index_p += 1;
4c4b4cd2 7357 }
828d5846
XR
7358
7359 /* Field not found so far. If this is a tagged type which
7360 has a parent, try finding that field in the parent now. */
7361
7362 if (parent_offset != -1)
7363 {
7364 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7365 int fld_offset = offset + bit_pos / 8;
7366
7367 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7368 fld_offset, field_type_p, byte_offset_p,
7369 bit_offset_p, bit_size_p, index_p))
7370 return 1;
7371 }
7372
4c4b4cd2
PH
7373 return 0;
7374}
7375
0963b4bd 7376/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7377
52ce6436
PH
7378static int
7379num_visible_fields (struct type *type)
7380{
7381 int n;
5b4ee69b 7382
52ce6436
PH
7383 n = 0;
7384 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7385 return n;
7386}
14f9c5c9 7387
4c4b4cd2 7388/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7389 and search in it assuming it has (class) type TYPE.
7390 If found, return value, else return NULL.
7391
828d5846
XR
7392 Searches recursively through wrapper fields (e.g., '_parent').
7393
7394 In the case of homonyms in the tagged types, please refer to the
7395 long explanation in find_struct_field's function documentation. */
14f9c5c9 7396
4c4b4cd2 7397static struct value *
108d56a4 7398ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7399 struct type *type)
14f9c5c9
AS
7400{
7401 int i;
828d5846 7402 int parent_offset = -1;
14f9c5c9 7403
5b4ee69b 7404 type = ada_check_typedef (type);
52ce6436 7405 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7406 {
0d5cff50 7407 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7408
7409 if (t_field_name == NULL)
4c4b4cd2 7410 continue;
14f9c5c9 7411
828d5846
XR
7412 else if (ada_is_parent_field (type, i))
7413 {
7414 /* This is a field pointing us to the parent type of a tagged
7415 type. As hinted in this function's documentation, we give
7416 preference to fields in the current record first, so what
7417 we do here is just record the index of this field before
7418 we skip it. If it turns out we couldn't find our field
7419 in the current record, then we'll get back to it and search
7420 inside it whether the field might exist in the parent. */
7421
7422 parent_offset = i;
7423 continue;
7424 }
7425
14f9c5c9 7426 else if (field_name_match (t_field_name, name))
4c4b4cd2 7427 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7428
7429 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7430 {
0963b4bd 7431 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7432 ada_search_struct_field (name, arg,
7433 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7434 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7435
4c4b4cd2
PH
7436 if (v != NULL)
7437 return v;
7438 }
14f9c5c9
AS
7439
7440 else if (ada_is_variant_part (type, i))
4c4b4cd2 7441 {
0963b4bd 7442 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7443 int j;
5b4ee69b
MS
7444 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7445 i));
4c4b4cd2
PH
7446 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7447
52ce6436 7448 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7449 {
0963b4bd
MS
7450 struct value *v = ada_search_struct_field /* Force line
7451 break. */
06d5cf63
JB
7452 (name, arg,
7453 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7454 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7455
4c4b4cd2
PH
7456 if (v != NULL)
7457 return v;
7458 }
7459 }
14f9c5c9 7460 }
828d5846
XR
7461
7462 /* Field not found so far. If this is a tagged type which
7463 has a parent, try finding that field in the parent now. */
7464
7465 if (parent_offset != -1)
7466 {
7467 struct value *v = ada_search_struct_field (
7468 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7469 TYPE_FIELD_TYPE (type, parent_offset));
7470
7471 if (v != NULL)
7472 return v;
7473 }
7474
14f9c5c9
AS
7475 return NULL;
7476}
d2e4a39e 7477
52ce6436
PH
7478static struct value *ada_index_struct_field_1 (int *, struct value *,
7479 int, struct type *);
7480
7481
7482/* Return field #INDEX in ARG, where the index is that returned by
7483 * find_struct_field through its INDEX_P argument. Adjust the address
7484 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7485 * If found, return value, else return NULL. */
52ce6436
PH
7486
7487static struct value *
7488ada_index_struct_field (int index, struct value *arg, int offset,
7489 struct type *type)
7490{
7491 return ada_index_struct_field_1 (&index, arg, offset, type);
7492}
7493
7494
7495/* Auxiliary function for ada_index_struct_field. Like
7496 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7497 * *INDEX_P. */
52ce6436
PH
7498
7499static struct value *
7500ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7501 struct type *type)
7502{
7503 int i;
7504 type = ada_check_typedef (type);
7505
7506 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7507 {
7508 if (TYPE_FIELD_NAME (type, i) == NULL)
7509 continue;
7510 else if (ada_is_wrapper_field (type, i))
7511 {
0963b4bd 7512 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7513 ada_index_struct_field_1 (index_p, arg,
7514 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7515 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7516
52ce6436
PH
7517 if (v != NULL)
7518 return v;
7519 }
7520
7521 else if (ada_is_variant_part (type, i))
7522 {
7523 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7524 find_struct_field. */
52ce6436
PH
7525 error (_("Cannot assign this kind of variant record"));
7526 }
7527 else if (*index_p == 0)
7528 return ada_value_primitive_field (arg, offset, i, type);
7529 else
7530 *index_p -= 1;
7531 }
7532 return NULL;
7533}
7534
4c4b4cd2
PH
7535/* Given ARG, a value of type (pointer or reference to a)*
7536 structure/union, extract the component named NAME from the ultimate
7537 target structure/union and return it as a value with its
f5938064 7538 appropriate type.
14f9c5c9 7539
4c4b4cd2
PH
7540 The routine searches for NAME among all members of the structure itself
7541 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7542 (e.g., '_parent').
7543
03ee6b2e
PH
7544 If NO_ERR, then simply return NULL in case of error, rather than
7545 calling error. */
14f9c5c9 7546
d2e4a39e 7547struct value *
a121b7c1 7548ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7549{
4c4b4cd2 7550 struct type *t, *t1;
d2e4a39e 7551 struct value *v;
14f9c5c9 7552
4c4b4cd2 7553 v = NULL;
df407dfe 7554 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7555 if (TYPE_CODE (t) == TYPE_CODE_REF)
7556 {
7557 t1 = TYPE_TARGET_TYPE (t);
7558 if (t1 == NULL)
03ee6b2e 7559 goto BadValue;
61ee279c 7560 t1 = ada_check_typedef (t1);
4c4b4cd2 7561 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7562 {
994b9211 7563 arg = coerce_ref (arg);
76a01679
JB
7564 t = t1;
7565 }
4c4b4cd2 7566 }
14f9c5c9 7567
4c4b4cd2
PH
7568 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7569 {
7570 t1 = TYPE_TARGET_TYPE (t);
7571 if (t1 == NULL)
03ee6b2e 7572 goto BadValue;
61ee279c 7573 t1 = ada_check_typedef (t1);
4c4b4cd2 7574 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7575 {
7576 arg = value_ind (arg);
7577 t = t1;
7578 }
4c4b4cd2 7579 else
76a01679 7580 break;
4c4b4cd2 7581 }
14f9c5c9 7582
4c4b4cd2 7583 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7584 goto BadValue;
14f9c5c9 7585
4c4b4cd2
PH
7586 if (t1 == t)
7587 v = ada_search_struct_field (name, arg, 0, t);
7588 else
7589 {
7590 int bit_offset, bit_size, byte_offset;
7591 struct type *field_type;
7592 CORE_ADDR address;
7593
76a01679 7594 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7595 address = value_address (ada_value_ind (arg));
4c4b4cd2 7596 else
b50d69b5 7597 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7598
828d5846
XR
7599 /* Check to see if this is a tagged type. We also need to handle
7600 the case where the type is a reference to a tagged type, but
7601 we have to be careful to exclude pointers to tagged types.
7602 The latter should be shown as usual (as a pointer), whereas
7603 a reference should mostly be transparent to the user. */
7604
7605 if (ada_is_tagged_type (t1, 0)
7606 || (TYPE_CODE (t1) == TYPE_CODE_REF
7607 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7608 {
7609 /* We first try to find the searched field in the current type.
7610 If not found then let's look in the fixed type. */
7611
7612 if (!find_struct_field (name, t1, 0,
7613 &field_type, &byte_offset, &bit_offset,
7614 &bit_size, NULL))
7615 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7616 address, NULL, 1);
7617 }
7618 else
7619 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7620 address, NULL, 1);
7621
76a01679
JB
7622 if (find_struct_field (name, t1, 0,
7623 &field_type, &byte_offset, &bit_offset,
52ce6436 7624 &bit_size, NULL))
76a01679
JB
7625 {
7626 if (bit_size != 0)
7627 {
714e53ab
PH
7628 if (TYPE_CODE (t) == TYPE_CODE_REF)
7629 arg = ada_coerce_ref (arg);
7630 else
7631 arg = ada_value_ind (arg);
76a01679
JB
7632 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7633 bit_offset, bit_size,
7634 field_type);
7635 }
7636 else
f5938064 7637 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7638 }
7639 }
7640
03ee6b2e
PH
7641 if (v != NULL || no_err)
7642 return v;
7643 else
323e0a4a 7644 error (_("There is no member named %s."), name);
14f9c5c9 7645
03ee6b2e
PH
7646 BadValue:
7647 if (no_err)
7648 return NULL;
7649 else
0963b4bd
MS
7650 error (_("Attempt to extract a component of "
7651 "a value that is not a record."));
14f9c5c9
AS
7652}
7653
3b4de39c 7654/* Return a string representation of type TYPE. */
99bbb428 7655
3b4de39c 7656static std::string
99bbb428
PA
7657type_as_string (struct type *type)
7658{
d7e74731 7659 string_file tmp_stream;
99bbb428 7660
d7e74731 7661 type_print (type, "", &tmp_stream, -1);
99bbb428 7662
d7e74731 7663 return std::move (tmp_stream.string ());
99bbb428
PA
7664}
7665
14f9c5c9 7666/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7667 If DISPP is non-null, add its byte displacement from the beginning of a
7668 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7669 work for packed fields).
7670
7671 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7672 followed by "___".
14f9c5c9 7673
0963b4bd 7674 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7675 be a (pointer or reference)+ to a struct or union, and the
7676 ultimate target type will be searched.
14f9c5c9
AS
7677
7678 Looks recursively into variant clauses and parent types.
7679
828d5846
XR
7680 In the case of homonyms in the tagged types, please refer to the
7681 long explanation in find_struct_field's function documentation.
7682
4c4b4cd2
PH
7683 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7684 TYPE is not a type of the right kind. */
14f9c5c9 7685
4c4b4cd2 7686static struct type *
a121b7c1 7687ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7688 int noerr)
14f9c5c9
AS
7689{
7690 int i;
828d5846 7691 int parent_offset = -1;
14f9c5c9
AS
7692
7693 if (name == NULL)
7694 goto BadName;
7695
76a01679 7696 if (refok && type != NULL)
4c4b4cd2
PH
7697 while (1)
7698 {
61ee279c 7699 type = ada_check_typedef (type);
76a01679
JB
7700 if (TYPE_CODE (type) != TYPE_CODE_PTR
7701 && TYPE_CODE (type) != TYPE_CODE_REF)
7702 break;
7703 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7704 }
14f9c5c9 7705
76a01679 7706 if (type == NULL
1265e4aa
JB
7707 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7708 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7709 {
4c4b4cd2 7710 if (noerr)
76a01679 7711 return NULL;
99bbb428 7712
3b4de39c
PA
7713 error (_("Type %s is not a structure or union type"),
7714 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7715 }
7716
7717 type = to_static_fixed_type (type);
7718
7719 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7720 {
0d5cff50 7721 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7722 struct type *t;
d2e4a39e 7723
14f9c5c9 7724 if (t_field_name == NULL)
4c4b4cd2 7725 continue;
14f9c5c9 7726
828d5846
XR
7727 else if (ada_is_parent_field (type, i))
7728 {
7729 /* This is a field pointing us to the parent type of a tagged
7730 type. As hinted in this function's documentation, we give
7731 preference to fields in the current record first, so what
7732 we do here is just record the index of this field before
7733 we skip it. If it turns out we couldn't find our field
7734 in the current record, then we'll get back to it and search
7735 inside it whether the field might exist in the parent. */
7736
7737 parent_offset = i;
7738 continue;
7739 }
7740
14f9c5c9 7741 else if (field_name_match (t_field_name, name))
988f6b3d 7742 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7743
7744 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7745 {
4c4b4cd2 7746 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7747 0, 1);
4c4b4cd2 7748 if (t != NULL)
988f6b3d 7749 return t;
4c4b4cd2 7750 }
14f9c5c9
AS
7751
7752 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7753 {
7754 int j;
5b4ee69b
MS
7755 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7756 i));
4c4b4cd2
PH
7757
7758 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7759 {
b1f33ddd
JB
7760 /* FIXME pnh 2008/01/26: We check for a field that is
7761 NOT wrapped in a struct, since the compiler sometimes
7762 generates these for unchecked variant types. Revisit
0963b4bd 7763 if the compiler changes this practice. */
0d5cff50 7764 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7765
b1f33ddd
JB
7766 if (v_field_name != NULL
7767 && field_name_match (v_field_name, name))
460efde1 7768 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7769 else
0963b4bd
MS
7770 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7771 j),
988f6b3d 7772 name, 0, 1);
b1f33ddd 7773
4c4b4cd2 7774 if (t != NULL)
988f6b3d 7775 return t;
4c4b4cd2
PH
7776 }
7777 }
14f9c5c9
AS
7778
7779 }
7780
828d5846
XR
7781 /* Field not found so far. If this is a tagged type which
7782 has a parent, try finding that field in the parent now. */
7783
7784 if (parent_offset != -1)
7785 {
7786 struct type *t;
7787
7788 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7789 name, 0, 1);
7790 if (t != NULL)
7791 return t;
7792 }
7793
14f9c5c9 7794BadName:
d2e4a39e 7795 if (!noerr)
14f9c5c9 7796 {
2b2798cc 7797 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7798
7799 error (_("Type %s has no component named %s"),
3b4de39c 7800 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7801 }
7802
7803 return NULL;
7804}
7805
b1f33ddd
JB
7806/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7807 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7808 represents an unchecked union (that is, the variant part of a
0963b4bd 7809 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7810
7811static int
7812is_unchecked_variant (struct type *var_type, struct type *outer_type)
7813{
a121b7c1 7814 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7815
988f6b3d 7816 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7817}
7818
7819
14f9c5c9
AS
7820/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7821 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7822 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7823 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7824
d2e4a39e 7825int
ebf56fd3 7826ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7827 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7828{
7829 int others_clause;
7830 int i;
a121b7c1 7831 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7832 struct value *outer;
7833 struct value *discrim;
14f9c5c9
AS
7834 LONGEST discrim_val;
7835
012370f6
TT
7836 /* Using plain value_from_contents_and_address here causes problems
7837 because we will end up trying to resolve a type that is currently
7838 being constructed. */
7839 outer = value_from_contents_and_address_unresolved (outer_type,
7840 outer_valaddr, 0);
0c281816
JB
7841 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7842 if (discrim == NULL)
14f9c5c9 7843 return -1;
0c281816 7844 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7845
7846 others_clause = -1;
7847 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7848 {
7849 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7850 others_clause = i;
14f9c5c9 7851 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7852 return i;
14f9c5c9
AS
7853 }
7854
7855 return others_clause;
7856}
d2e4a39e 7857\f
14f9c5c9
AS
7858
7859
4c4b4cd2 7860 /* Dynamic-Sized Records */
14f9c5c9
AS
7861
7862/* Strategy: The type ostensibly attached to a value with dynamic size
7863 (i.e., a size that is not statically recorded in the debugging
7864 data) does not accurately reflect the size or layout of the value.
7865 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7866 conventional types that are constructed on the fly. */
14f9c5c9
AS
7867
7868/* There is a subtle and tricky problem here. In general, we cannot
7869 determine the size of dynamic records without its data. However,
7870 the 'struct value' data structure, which GDB uses to represent
7871 quantities in the inferior process (the target), requires the size
7872 of the type at the time of its allocation in order to reserve space
7873 for GDB's internal copy of the data. That's why the
7874 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7875 rather than struct value*s.
14f9c5c9
AS
7876
7877 However, GDB's internal history variables ($1, $2, etc.) are
7878 struct value*s containing internal copies of the data that are not, in
7879 general, the same as the data at their corresponding addresses in
7880 the target. Fortunately, the types we give to these values are all
7881 conventional, fixed-size types (as per the strategy described
7882 above), so that we don't usually have to perform the
7883 'to_fixed_xxx_type' conversions to look at their values.
7884 Unfortunately, there is one exception: if one of the internal
7885 history variables is an array whose elements are unconstrained
7886 records, then we will need to create distinct fixed types for each
7887 element selected. */
7888
7889/* The upshot of all of this is that many routines take a (type, host
7890 address, target address) triple as arguments to represent a value.
7891 The host address, if non-null, is supposed to contain an internal
7892 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7893 target at the target address. */
14f9c5c9
AS
7894
7895/* Assuming that VAL0 represents a pointer value, the result of
7896 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7897 dynamic-sized types. */
14f9c5c9 7898
d2e4a39e
AS
7899struct value *
7900ada_value_ind (struct value *val0)
14f9c5c9 7901{
c48db5ca 7902 struct value *val = value_ind (val0);
5b4ee69b 7903
b50d69b5
JG
7904 if (ada_is_tagged_type (value_type (val), 0))
7905 val = ada_tag_value_at_base_address (val);
7906
4c4b4cd2 7907 return ada_to_fixed_value (val);
14f9c5c9
AS
7908}
7909
7910/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7911 qualifiers on VAL0. */
7912
d2e4a39e
AS
7913static struct value *
7914ada_coerce_ref (struct value *val0)
7915{
df407dfe 7916 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7917 {
7918 struct value *val = val0;
5b4ee69b 7919
994b9211 7920 val = coerce_ref (val);
b50d69b5
JG
7921
7922 if (ada_is_tagged_type (value_type (val), 0))
7923 val = ada_tag_value_at_base_address (val);
7924
4c4b4cd2 7925 return ada_to_fixed_value (val);
d2e4a39e
AS
7926 }
7927 else
14f9c5c9
AS
7928 return val0;
7929}
7930
7931/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7932 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7933
7934static unsigned int
ebf56fd3 7935align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7936{
7937 return (off + alignment - 1) & ~(alignment - 1);
7938}
7939
4c4b4cd2 7940/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7941
7942static unsigned int
ebf56fd3 7943field_alignment (struct type *type, int f)
14f9c5c9 7944{
d2e4a39e 7945 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7946 int len;
14f9c5c9
AS
7947 int align_offset;
7948
64a1bf19
JB
7949 /* The field name should never be null, unless the debugging information
7950 is somehow malformed. In this case, we assume the field does not
7951 require any alignment. */
7952 if (name == NULL)
7953 return 1;
7954
7955 len = strlen (name);
7956
4c4b4cd2
PH
7957 if (!isdigit (name[len - 1]))
7958 return 1;
14f9c5c9 7959
d2e4a39e 7960 if (isdigit (name[len - 2]))
14f9c5c9
AS
7961 align_offset = len - 2;
7962 else
7963 align_offset = len - 1;
7964
61012eef 7965 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7966 return TARGET_CHAR_BIT;
7967
4c4b4cd2
PH
7968 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7969}
7970
852dff6c 7971/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7972
852dff6c
JB
7973static struct symbol *
7974ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7975{
7976 struct symbol *sym;
7977
7978 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7979 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7980 return sym;
7981
4186eb54
KS
7982 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7983 return sym;
14f9c5c9
AS
7984}
7985
dddfab26
UW
7986/* Find a type named NAME. Ignores ambiguity. This routine will look
7987 solely for types defined by debug info, it will not search the GDB
7988 primitive types. */
4c4b4cd2 7989
852dff6c 7990static struct type *
ebf56fd3 7991ada_find_any_type (const char *name)
14f9c5c9 7992{
852dff6c 7993 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7994
14f9c5c9 7995 if (sym != NULL)
dddfab26 7996 return SYMBOL_TYPE (sym);
14f9c5c9 7997
dddfab26 7998 return NULL;
14f9c5c9
AS
7999}
8000
739593e0
JB
8001/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
8002 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
8003 symbol, in which case it is returned. Otherwise, this looks for
8004 symbols whose name is that of NAME_SYM suffixed with "___XR".
8005 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
8006
8007struct symbol *
270140bd 8008ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 8009{
739593e0 8010 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
8011 struct symbol *sym;
8012
739593e0
JB
8013 if (strstr (name, "___XR") != NULL)
8014 return name_sym;
8015
aeb5907d
JB
8016 sym = find_old_style_renaming_symbol (name, block);
8017
8018 if (sym != NULL)
8019 return sym;
8020
0963b4bd 8021 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 8022 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
8023 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
8024 return sym;
8025 else
8026 return NULL;
8027}
8028
8029static struct symbol *
270140bd 8030find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 8031{
7f0df278 8032 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
8033 char *rename;
8034
8035 if (function_sym != NULL)
8036 {
8037 /* If the symbol is defined inside a function, NAME is not fully
8038 qualified. This means we need to prepend the function name
8039 as well as adding the ``___XR'' suffix to build the name of
8040 the associated renaming symbol. */
0d5cff50 8041 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
8042 /* Function names sometimes contain suffixes used
8043 for instance to qualify nested subprograms. When building
8044 the XR type name, we need to make sure that this suffix is
8045 not included. So do not include any suffix in the function
8046 name length below. */
69fadcdf 8047 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
8048 const int rename_len = function_name_len + 2 /* "__" */
8049 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 8050
529cad9c 8051 /* Strip the suffix if necessary. */
69fadcdf
JB
8052 ada_remove_trailing_digits (function_name, &function_name_len);
8053 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8054 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 8055
4c4b4cd2
PH
8056 /* Library-level functions are a special case, as GNAT adds
8057 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 8058 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
8059 have this prefix, so we need to skip this prefix if present. */
8060 if (function_name_len > 5 /* "_ada_" */
8061 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
8062 {
8063 function_name += 5;
8064 function_name_len -= 5;
8065 }
4c4b4cd2
PH
8066
8067 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
8068 strncpy (rename, function_name, function_name_len);
8069 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8070 "__%s___XR", name);
4c4b4cd2
PH
8071 }
8072 else
8073 {
8074 const int rename_len = strlen (name) + 6;
5b4ee69b 8075
4c4b4cd2 8076 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 8077 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
8078 }
8079
852dff6c 8080 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
8081}
8082
14f9c5c9 8083/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 8084 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 8085 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
8086 otherwise return 0. */
8087
14f9c5c9 8088int
d2e4a39e 8089ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
8090{
8091 if (type1 == NULL)
8092 return 1;
8093 else if (type0 == NULL)
8094 return 0;
8095 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8096 return 1;
8097 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8098 return 0;
4c4b4cd2
PH
8099 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8100 return 1;
ad82864c 8101 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8102 return 1;
4c4b4cd2
PH
8103 else if (ada_is_array_descriptor_type (type0)
8104 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8105 return 1;
aeb5907d
JB
8106 else
8107 {
8108 const char *type0_name = type_name_no_tag (type0);
8109 const char *type1_name = type_name_no_tag (type1);
8110
8111 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8112 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8113 return 1;
8114 }
14f9c5c9
AS
8115 return 0;
8116}
8117
8118/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
8119 null, its TYPE_TAG_NAME. Null if TYPE is null. */
8120
0d5cff50 8121const char *
d2e4a39e 8122ada_type_name (struct type *type)
14f9c5c9 8123{
d2e4a39e 8124 if (type == NULL)
14f9c5c9
AS
8125 return NULL;
8126 else if (TYPE_NAME (type) != NULL)
8127 return TYPE_NAME (type);
8128 else
8129 return TYPE_TAG_NAME (type);
8130}
8131
b4ba55a1
JB
8132/* Search the list of "descriptive" types associated to TYPE for a type
8133 whose name is NAME. */
8134
8135static struct type *
8136find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8137{
931e5bc3 8138 struct type *result, *tmp;
b4ba55a1 8139
c6044dd1
JB
8140 if (ada_ignore_descriptive_types_p)
8141 return NULL;
8142
b4ba55a1
JB
8143 /* If there no descriptive-type info, then there is no parallel type
8144 to be found. */
8145 if (!HAVE_GNAT_AUX_INFO (type))
8146 return NULL;
8147
8148 result = TYPE_DESCRIPTIVE_TYPE (type);
8149 while (result != NULL)
8150 {
0d5cff50 8151 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8152
8153 if (result_name == NULL)
8154 {
8155 warning (_("unexpected null name on descriptive type"));
8156 return NULL;
8157 }
8158
8159 /* If the names match, stop. */
8160 if (strcmp (result_name, name) == 0)
8161 break;
8162
8163 /* Otherwise, look at the next item on the list, if any. */
8164 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8165 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8166 else
8167 tmp = NULL;
8168
8169 /* If not found either, try after having resolved the typedef. */
8170 if (tmp != NULL)
8171 result = tmp;
b4ba55a1 8172 else
931e5bc3 8173 {
f168693b 8174 result = check_typedef (result);
931e5bc3
JG
8175 if (HAVE_GNAT_AUX_INFO (result))
8176 result = TYPE_DESCRIPTIVE_TYPE (result);
8177 else
8178 result = NULL;
8179 }
b4ba55a1
JB
8180 }
8181
8182 /* If we didn't find a match, see whether this is a packed array. With
8183 older compilers, the descriptive type information is either absent or
8184 irrelevant when it comes to packed arrays so the above lookup fails.
8185 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8186 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8187 return ada_find_any_type (name);
8188
8189 return result;
8190}
8191
8192/* Find a parallel type to TYPE with the specified NAME, using the
8193 descriptive type taken from the debugging information, if available,
8194 and otherwise using the (slower) name-based method. */
8195
8196static struct type *
8197ada_find_parallel_type_with_name (struct type *type, const char *name)
8198{
8199 struct type *result = NULL;
8200
8201 if (HAVE_GNAT_AUX_INFO (type))
8202 result = find_parallel_type_by_descriptive_type (type, name);
8203 else
8204 result = ada_find_any_type (name);
8205
8206 return result;
8207}
8208
8209/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8210 SUFFIX to the name of TYPE. */
14f9c5c9 8211
d2e4a39e 8212struct type *
ebf56fd3 8213ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8214{
0d5cff50 8215 char *name;
fe978cb0 8216 const char *type_name = ada_type_name (type);
14f9c5c9 8217 int len;
d2e4a39e 8218
fe978cb0 8219 if (type_name == NULL)
14f9c5c9
AS
8220 return NULL;
8221
fe978cb0 8222 len = strlen (type_name);
14f9c5c9 8223
b4ba55a1 8224 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8225
fe978cb0 8226 strcpy (name, type_name);
14f9c5c9
AS
8227 strcpy (name + len, suffix);
8228
b4ba55a1 8229 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8230}
8231
14f9c5c9 8232/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8233 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8234
d2e4a39e
AS
8235static struct type *
8236dynamic_template_type (struct type *type)
14f9c5c9 8237{
61ee279c 8238 type = ada_check_typedef (type);
14f9c5c9
AS
8239
8240 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8241 || ada_type_name (type) == NULL)
14f9c5c9 8242 return NULL;
d2e4a39e 8243 else
14f9c5c9
AS
8244 {
8245 int len = strlen (ada_type_name (type));
5b4ee69b 8246
4c4b4cd2
PH
8247 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8248 return type;
14f9c5c9 8249 else
4c4b4cd2 8250 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8251 }
8252}
8253
8254/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8255 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8256
d2e4a39e
AS
8257static int
8258is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8259{
8260 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8261
d2e4a39e 8262 return name != NULL
14f9c5c9
AS
8263 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8264 && strstr (name, "___XVL") != NULL;
8265}
8266
4c4b4cd2
PH
8267/* The index of the variant field of TYPE, or -1 if TYPE does not
8268 represent a variant record type. */
14f9c5c9 8269
d2e4a39e 8270static int
4c4b4cd2 8271variant_field_index (struct type *type)
14f9c5c9
AS
8272{
8273 int f;
8274
4c4b4cd2
PH
8275 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8276 return -1;
8277
8278 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8279 {
8280 if (ada_is_variant_part (type, f))
8281 return f;
8282 }
8283 return -1;
14f9c5c9
AS
8284}
8285
4c4b4cd2
PH
8286/* A record type with no fields. */
8287
d2e4a39e 8288static struct type *
fe978cb0 8289empty_record (struct type *templ)
14f9c5c9 8290{
fe978cb0 8291 struct type *type = alloc_type_copy (templ);
5b4ee69b 8292
14f9c5c9
AS
8293 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8294 TYPE_NFIELDS (type) = 0;
8295 TYPE_FIELDS (type) = NULL;
b1f33ddd 8296 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
8297 TYPE_NAME (type) = "<empty>";
8298 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
8299 TYPE_LENGTH (type) = 0;
8300 return type;
8301}
8302
8303/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8304 the value of type TYPE at VALADDR or ADDRESS (see comments at
8305 the beginning of this section) VAL according to GNAT conventions.
8306 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8307 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8308 an outer-level type (i.e., as opposed to a branch of a variant.) A
8309 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8310 of the variant.
14f9c5c9 8311
4c4b4cd2
PH
8312 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8313 length are not statically known are discarded. As a consequence,
8314 VALADDR, ADDRESS and DVAL0 are ignored.
8315
8316 NOTE: Limitations: For now, we assume that dynamic fields and
8317 variants occupy whole numbers of bytes. However, they need not be
8318 byte-aligned. */
8319
8320struct type *
10a2c479 8321ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8322 const gdb_byte *valaddr,
4c4b4cd2
PH
8323 CORE_ADDR address, struct value *dval0,
8324 int keep_dynamic_fields)
14f9c5c9 8325{
d2e4a39e
AS
8326 struct value *mark = value_mark ();
8327 struct value *dval;
8328 struct type *rtype;
14f9c5c9 8329 int nfields, bit_len;
4c4b4cd2 8330 int variant_field;
14f9c5c9 8331 long off;
d94e4f4f 8332 int fld_bit_len;
14f9c5c9
AS
8333 int f;
8334
4c4b4cd2
PH
8335 /* Compute the number of fields in this record type that are going
8336 to be processed: unless keep_dynamic_fields, this includes only
8337 fields whose position and length are static will be processed. */
8338 if (keep_dynamic_fields)
8339 nfields = TYPE_NFIELDS (type);
8340 else
8341 {
8342 nfields = 0;
76a01679 8343 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8344 && !ada_is_variant_part (type, nfields)
8345 && !is_dynamic_field (type, nfields))
8346 nfields++;
8347 }
8348
e9bb382b 8349 rtype = alloc_type_copy (type);
14f9c5c9
AS
8350 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8351 INIT_CPLUS_SPECIFIC (rtype);
8352 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8353 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8354 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8355 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8356 TYPE_NAME (rtype) = ada_type_name (type);
8357 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8358 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8359
d2e4a39e
AS
8360 off = 0;
8361 bit_len = 0;
4c4b4cd2
PH
8362 variant_field = -1;
8363
14f9c5c9
AS
8364 for (f = 0; f < nfields; f += 1)
8365 {
6c038f32
PH
8366 off = align_value (off, field_alignment (type, f))
8367 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8368 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8369 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8370
d2e4a39e 8371 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8372 {
8373 variant_field = f;
d94e4f4f 8374 fld_bit_len = 0;
4c4b4cd2 8375 }
14f9c5c9 8376 else if (is_dynamic_field (type, f))
4c4b4cd2 8377 {
284614f0
JB
8378 const gdb_byte *field_valaddr = valaddr;
8379 CORE_ADDR field_address = address;
8380 struct type *field_type =
8381 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8382
4c4b4cd2 8383 if (dval0 == NULL)
b5304971
JG
8384 {
8385 /* rtype's length is computed based on the run-time
8386 value of discriminants. If the discriminants are not
8387 initialized, the type size may be completely bogus and
0963b4bd 8388 GDB may fail to allocate a value for it. So check the
b5304971 8389 size first before creating the value. */
c1b5a1a6 8390 ada_ensure_varsize_limit (rtype);
012370f6
TT
8391 /* Using plain value_from_contents_and_address here
8392 causes problems because we will end up trying to
8393 resolve a type that is currently being
8394 constructed. */
8395 dval = value_from_contents_and_address_unresolved (rtype,
8396 valaddr,
8397 address);
9f1f738a 8398 rtype = value_type (dval);
b5304971 8399 }
4c4b4cd2
PH
8400 else
8401 dval = dval0;
8402
284614f0
JB
8403 /* If the type referenced by this field is an aligner type, we need
8404 to unwrap that aligner type, because its size might not be set.
8405 Keeping the aligner type would cause us to compute the wrong
8406 size for this field, impacting the offset of the all the fields
8407 that follow this one. */
8408 if (ada_is_aligner_type (field_type))
8409 {
8410 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8411
8412 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8413 field_address = cond_offset_target (field_address, field_offset);
8414 field_type = ada_aligned_type (field_type);
8415 }
8416
8417 field_valaddr = cond_offset_host (field_valaddr,
8418 off / TARGET_CHAR_BIT);
8419 field_address = cond_offset_target (field_address,
8420 off / TARGET_CHAR_BIT);
8421
8422 /* Get the fixed type of the field. Note that, in this case,
8423 we do not want to get the real type out of the tag: if
8424 the current field is the parent part of a tagged record,
8425 we will get the tag of the object. Clearly wrong: the real
8426 type of the parent is not the real type of the child. We
8427 would end up in an infinite loop. */
8428 field_type = ada_get_base_type (field_type);
8429 field_type = ada_to_fixed_type (field_type, field_valaddr,
8430 field_address, dval, 0);
27f2a97b
JB
8431 /* If the field size is already larger than the maximum
8432 object size, then the record itself will necessarily
8433 be larger than the maximum object size. We need to make
8434 this check now, because the size might be so ridiculously
8435 large (due to an uninitialized variable in the inferior)
8436 that it would cause an overflow when adding it to the
8437 record size. */
c1b5a1a6 8438 ada_ensure_varsize_limit (field_type);
284614f0
JB
8439
8440 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8441 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8442 /* The multiplication can potentially overflow. But because
8443 the field length has been size-checked just above, and
8444 assuming that the maximum size is a reasonable value,
8445 an overflow should not happen in practice. So rather than
8446 adding overflow recovery code to this already complex code,
8447 we just assume that it's not going to happen. */
d94e4f4f 8448 fld_bit_len =
4c4b4cd2
PH
8449 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8450 }
14f9c5c9 8451 else
4c4b4cd2 8452 {
5ded5331
JB
8453 /* Note: If this field's type is a typedef, it is important
8454 to preserve the typedef layer.
8455
8456 Otherwise, we might be transforming a typedef to a fat
8457 pointer (encoding a pointer to an unconstrained array),
8458 into a basic fat pointer (encoding an unconstrained
8459 array). As both types are implemented using the same
8460 structure, the typedef is the only clue which allows us
8461 to distinguish between the two options. Stripping it
8462 would prevent us from printing this field appropriately. */
8463 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8464 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8465 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8466 fld_bit_len =
4c4b4cd2
PH
8467 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8468 else
5ded5331
JB
8469 {
8470 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8471
8472 /* We need to be careful of typedefs when computing
8473 the length of our field. If this is a typedef,
8474 get the length of the target type, not the length
8475 of the typedef. */
8476 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8477 field_type = ada_typedef_target_type (field_type);
8478
8479 fld_bit_len =
8480 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8481 }
4c4b4cd2 8482 }
14f9c5c9 8483 if (off + fld_bit_len > bit_len)
4c4b4cd2 8484 bit_len = off + fld_bit_len;
d94e4f4f 8485 off += fld_bit_len;
4c4b4cd2
PH
8486 TYPE_LENGTH (rtype) =
8487 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8488 }
4c4b4cd2
PH
8489
8490 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8491 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8492 the record. This can happen in the presence of representation
8493 clauses. */
8494 if (variant_field >= 0)
8495 {
8496 struct type *branch_type;
8497
8498 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8499
8500 if (dval0 == NULL)
9f1f738a 8501 {
012370f6
TT
8502 /* Using plain value_from_contents_and_address here causes
8503 problems because we will end up trying to resolve a type
8504 that is currently being constructed. */
8505 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8506 address);
9f1f738a
SA
8507 rtype = value_type (dval);
8508 }
4c4b4cd2
PH
8509 else
8510 dval = dval0;
8511
8512 branch_type =
8513 to_fixed_variant_branch_type
8514 (TYPE_FIELD_TYPE (type, variant_field),
8515 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8516 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8517 if (branch_type == NULL)
8518 {
8519 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8520 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8521 TYPE_NFIELDS (rtype) -= 1;
8522 }
8523 else
8524 {
8525 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8526 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8527 fld_bit_len =
8528 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8529 TARGET_CHAR_BIT;
8530 if (off + fld_bit_len > bit_len)
8531 bit_len = off + fld_bit_len;
8532 TYPE_LENGTH (rtype) =
8533 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8534 }
8535 }
8536
714e53ab
PH
8537 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8538 should contain the alignment of that record, which should be a strictly
8539 positive value. If null or negative, then something is wrong, most
8540 probably in the debug info. In that case, we don't round up the size
0963b4bd 8541 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8542 the current RTYPE length might be good enough for our purposes. */
8543 if (TYPE_LENGTH (type) <= 0)
8544 {
323e0a4a
AC
8545 if (TYPE_NAME (rtype))
8546 warning (_("Invalid type size for `%s' detected: %d."),
8547 TYPE_NAME (rtype), TYPE_LENGTH (type));
8548 else
8549 warning (_("Invalid type size for <unnamed> detected: %d."),
8550 TYPE_LENGTH (type));
714e53ab
PH
8551 }
8552 else
8553 {
8554 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8555 TYPE_LENGTH (type));
8556 }
14f9c5c9
AS
8557
8558 value_free_to_mark (mark);
d2e4a39e 8559 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8560 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8561 return rtype;
8562}
8563
4c4b4cd2
PH
8564/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8565 of 1. */
14f9c5c9 8566
d2e4a39e 8567static struct type *
fc1a4b47 8568template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8569 CORE_ADDR address, struct value *dval0)
8570{
8571 return ada_template_to_fixed_record_type_1 (type, valaddr,
8572 address, dval0, 1);
8573}
8574
8575/* An ordinary record type in which ___XVL-convention fields and
8576 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8577 static approximations, containing all possible fields. Uses
8578 no runtime values. Useless for use in values, but that's OK,
8579 since the results are used only for type determinations. Works on both
8580 structs and unions. Representation note: to save space, we memorize
8581 the result of this function in the TYPE_TARGET_TYPE of the
8582 template type. */
8583
8584static struct type *
8585template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8586{
8587 struct type *type;
8588 int nfields;
8589 int f;
8590
9e195661
PMR
8591 /* No need no do anything if the input type is already fixed. */
8592 if (TYPE_FIXED_INSTANCE (type0))
8593 return type0;
8594
8595 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8596 if (TYPE_TARGET_TYPE (type0) != NULL)
8597 return TYPE_TARGET_TYPE (type0);
8598
9e195661 8599 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8600 type = type0;
9e195661
PMR
8601 nfields = TYPE_NFIELDS (type0);
8602
8603 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8604 recompute all over next time. */
8605 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8606
8607 for (f = 0; f < nfields; f += 1)
8608 {
460efde1 8609 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8610 struct type *new_type;
14f9c5c9 8611
4c4b4cd2 8612 if (is_dynamic_field (type0, f))
460efde1
JB
8613 {
8614 field_type = ada_check_typedef (field_type);
8615 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8616 }
14f9c5c9 8617 else
f192137b 8618 new_type = static_unwrap_type (field_type);
9e195661
PMR
8619
8620 if (new_type != field_type)
8621 {
8622 /* Clone TYPE0 only the first time we get a new field type. */
8623 if (type == type0)
8624 {
8625 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8626 TYPE_CODE (type) = TYPE_CODE (type0);
8627 INIT_CPLUS_SPECIFIC (type);
8628 TYPE_NFIELDS (type) = nfields;
8629 TYPE_FIELDS (type) = (struct field *)
8630 TYPE_ALLOC (type, nfields * sizeof (struct field));
8631 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8632 sizeof (struct field) * nfields);
8633 TYPE_NAME (type) = ada_type_name (type0);
8634 TYPE_TAG_NAME (type) = NULL;
8635 TYPE_FIXED_INSTANCE (type) = 1;
8636 TYPE_LENGTH (type) = 0;
8637 }
8638 TYPE_FIELD_TYPE (type, f) = new_type;
8639 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8640 }
14f9c5c9 8641 }
9e195661 8642
14f9c5c9
AS
8643 return type;
8644}
8645
4c4b4cd2 8646/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8647 whose address in memory is ADDRESS, returns a revision of TYPE,
8648 which should be a non-dynamic-sized record, in which the variant
8649 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8650 for discriminant values in DVAL0, which can be NULL if the record
8651 contains the necessary discriminant values. */
8652
d2e4a39e 8653static struct type *
fc1a4b47 8654to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8655 CORE_ADDR address, struct value *dval0)
14f9c5c9 8656{
d2e4a39e 8657 struct value *mark = value_mark ();
4c4b4cd2 8658 struct value *dval;
d2e4a39e 8659 struct type *rtype;
14f9c5c9
AS
8660 struct type *branch_type;
8661 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8662 int variant_field = variant_field_index (type);
14f9c5c9 8663
4c4b4cd2 8664 if (variant_field == -1)
14f9c5c9
AS
8665 return type;
8666
4c4b4cd2 8667 if (dval0 == NULL)
9f1f738a
SA
8668 {
8669 dval = value_from_contents_and_address (type, valaddr, address);
8670 type = value_type (dval);
8671 }
4c4b4cd2
PH
8672 else
8673 dval = dval0;
8674
e9bb382b 8675 rtype = alloc_type_copy (type);
14f9c5c9 8676 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8677 INIT_CPLUS_SPECIFIC (rtype);
8678 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8679 TYPE_FIELDS (rtype) =
8680 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8681 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8682 sizeof (struct field) * nfields);
14f9c5c9
AS
8683 TYPE_NAME (rtype) = ada_type_name (type);
8684 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8685 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8686 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8687
4c4b4cd2
PH
8688 branch_type = to_fixed_variant_branch_type
8689 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8690 cond_offset_host (valaddr,
4c4b4cd2
PH
8691 TYPE_FIELD_BITPOS (type, variant_field)
8692 / TARGET_CHAR_BIT),
d2e4a39e 8693 cond_offset_target (address,
4c4b4cd2
PH
8694 TYPE_FIELD_BITPOS (type, variant_field)
8695 / TARGET_CHAR_BIT), dval);
d2e4a39e 8696 if (branch_type == NULL)
14f9c5c9 8697 {
4c4b4cd2 8698 int f;
5b4ee69b 8699
4c4b4cd2
PH
8700 for (f = variant_field + 1; f < nfields; f += 1)
8701 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8702 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8703 }
8704 else
8705 {
4c4b4cd2
PH
8706 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8707 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8708 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8709 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8710 }
4c4b4cd2 8711 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8712
4c4b4cd2 8713 value_free_to_mark (mark);
14f9c5c9
AS
8714 return rtype;
8715}
8716
8717/* An ordinary record type (with fixed-length fields) that describes
8718 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8719 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8720 should be in DVAL, a record value; it may be NULL if the object
8721 at ADDR itself contains any necessary discriminant values.
8722 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8723 values from the record are needed. Except in the case that DVAL,
8724 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8725 unchecked) is replaced by a particular branch of the variant.
8726
8727 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8728 is questionable and may be removed. It can arise during the
8729 processing of an unconstrained-array-of-record type where all the
8730 variant branches have exactly the same size. This is because in
8731 such cases, the compiler does not bother to use the XVS convention
8732 when encoding the record. I am currently dubious of this
8733 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8734
d2e4a39e 8735static struct type *
fc1a4b47 8736to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8737 CORE_ADDR address, struct value *dval)
14f9c5c9 8738{
d2e4a39e 8739 struct type *templ_type;
14f9c5c9 8740
876cecd0 8741 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8742 return type0;
8743
d2e4a39e 8744 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8745
8746 if (templ_type != NULL)
8747 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8748 else if (variant_field_index (type0) >= 0)
8749 {
8750 if (dval == NULL && valaddr == NULL && address == 0)
8751 return type0;
8752 return to_record_with_fixed_variant_part (type0, valaddr, address,
8753 dval);
8754 }
14f9c5c9
AS
8755 else
8756 {
876cecd0 8757 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8758 return type0;
8759 }
8760
8761}
8762
8763/* An ordinary record type (with fixed-length fields) that describes
8764 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8765 union type. Any necessary discriminants' values should be in DVAL,
8766 a record value. That is, this routine selects the appropriate
8767 branch of the union at ADDR according to the discriminant value
b1f33ddd 8768 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8769 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8770
d2e4a39e 8771static struct type *
fc1a4b47 8772to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8773 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8774{
8775 int which;
d2e4a39e
AS
8776 struct type *templ_type;
8777 struct type *var_type;
14f9c5c9
AS
8778
8779 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8780 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8781 else
14f9c5c9
AS
8782 var_type = var_type0;
8783
8784 templ_type = ada_find_parallel_type (var_type, "___XVU");
8785
8786 if (templ_type != NULL)
8787 var_type = templ_type;
8788
b1f33ddd
JB
8789 if (is_unchecked_variant (var_type, value_type (dval)))
8790 return var_type0;
d2e4a39e
AS
8791 which =
8792 ada_which_variant_applies (var_type,
0fd88904 8793 value_type (dval), value_contents (dval));
14f9c5c9
AS
8794
8795 if (which < 0)
e9bb382b 8796 return empty_record (var_type);
14f9c5c9 8797 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8798 return to_fixed_record_type
d2e4a39e
AS
8799 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8800 valaddr, address, dval);
4c4b4cd2 8801 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8802 return
8803 to_fixed_record_type
8804 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8805 else
8806 return TYPE_FIELD_TYPE (var_type, which);
8807}
8808
8908fca5
JB
8809/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8810 ENCODING_TYPE, a type following the GNAT conventions for discrete
8811 type encodings, only carries redundant information. */
8812
8813static int
8814ada_is_redundant_range_encoding (struct type *range_type,
8815 struct type *encoding_type)
8816{
108d56a4 8817 const char *bounds_str;
8908fca5
JB
8818 int n;
8819 LONGEST lo, hi;
8820
8821 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8822
005e2509
JB
8823 if (TYPE_CODE (get_base_type (range_type))
8824 != TYPE_CODE (get_base_type (encoding_type)))
8825 {
8826 /* The compiler probably used a simple base type to describe
8827 the range type instead of the range's actual base type,
8828 expecting us to get the real base type from the encoding
8829 anyway. In this situation, the encoding cannot be ignored
8830 as redundant. */
8831 return 0;
8832 }
8833
8908fca5
JB
8834 if (is_dynamic_type (range_type))
8835 return 0;
8836
8837 if (TYPE_NAME (encoding_type) == NULL)
8838 return 0;
8839
8840 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8841 if (bounds_str == NULL)
8842 return 0;
8843
8844 n = 8; /* Skip "___XDLU_". */
8845 if (!ada_scan_number (bounds_str, n, &lo, &n))
8846 return 0;
8847 if (TYPE_LOW_BOUND (range_type) != lo)
8848 return 0;
8849
8850 n += 2; /* Skip the "__" separator between the two bounds. */
8851 if (!ada_scan_number (bounds_str, n, &hi, &n))
8852 return 0;
8853 if (TYPE_HIGH_BOUND (range_type) != hi)
8854 return 0;
8855
8856 return 1;
8857}
8858
8859/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8860 a type following the GNAT encoding for describing array type
8861 indices, only carries redundant information. */
8862
8863static int
8864ada_is_redundant_index_type_desc (struct type *array_type,
8865 struct type *desc_type)
8866{
8867 struct type *this_layer = check_typedef (array_type);
8868 int i;
8869
8870 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8871 {
8872 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8873 TYPE_FIELD_TYPE (desc_type, i)))
8874 return 0;
8875 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8876 }
8877
8878 return 1;
8879}
8880
14f9c5c9
AS
8881/* Assuming that TYPE0 is an array type describing the type of a value
8882 at ADDR, and that DVAL describes a record containing any
8883 discriminants used in TYPE0, returns a type for the value that
8884 contains no dynamic components (that is, no components whose sizes
8885 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8886 true, gives an error message if the resulting type's size is over
4c4b4cd2 8887 varsize_limit. */
14f9c5c9 8888
d2e4a39e
AS
8889static struct type *
8890to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8891 int ignore_too_big)
14f9c5c9 8892{
d2e4a39e
AS
8893 struct type *index_type_desc;
8894 struct type *result;
ad82864c 8895 int constrained_packed_array_p;
931e5bc3 8896 static const char *xa_suffix = "___XA";
14f9c5c9 8897
b0dd7688 8898 type0 = ada_check_typedef (type0);
284614f0 8899 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8900 return type0;
14f9c5c9 8901
ad82864c
JB
8902 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8903 if (constrained_packed_array_p)
8904 type0 = decode_constrained_packed_array_type (type0);
284614f0 8905
931e5bc3
JG
8906 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8907
8908 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8909 encoding suffixed with 'P' may still be generated. If so,
8910 it should be used to find the XA type. */
8911
8912 if (index_type_desc == NULL)
8913 {
1da0522e 8914 const char *type_name = ada_type_name (type0);
931e5bc3 8915
1da0522e 8916 if (type_name != NULL)
931e5bc3 8917 {
1da0522e 8918 const int len = strlen (type_name);
931e5bc3
JG
8919 char *name = (char *) alloca (len + strlen (xa_suffix));
8920
1da0522e 8921 if (type_name[len - 1] == 'P')
931e5bc3 8922 {
1da0522e 8923 strcpy (name, type_name);
931e5bc3
JG
8924 strcpy (name + len - 1, xa_suffix);
8925 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8926 }
8927 }
8928 }
8929
28c85d6c 8930 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8931 if (index_type_desc != NULL
8932 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8933 {
8934 /* Ignore this ___XA parallel type, as it does not bring any
8935 useful information. This allows us to avoid creating fixed
8936 versions of the array's index types, which would be identical
8937 to the original ones. This, in turn, can also help avoid
8938 the creation of fixed versions of the array itself. */
8939 index_type_desc = NULL;
8940 }
8941
14f9c5c9
AS
8942 if (index_type_desc == NULL)
8943 {
61ee279c 8944 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8945
14f9c5c9 8946 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8947 depend on the contents of the array in properly constructed
8948 debugging data. */
529cad9c
PH
8949 /* Create a fixed version of the array element type.
8950 We're not providing the address of an element here,
e1d5a0d2 8951 and thus the actual object value cannot be inspected to do
529cad9c
PH
8952 the conversion. This should not be a problem, since arrays of
8953 unconstrained objects are not allowed. In particular, all
8954 the elements of an array of a tagged type should all be of
8955 the same type specified in the debugging info. No need to
8956 consult the object tag. */
1ed6ede0 8957 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8958
284614f0
JB
8959 /* Make sure we always create a new array type when dealing with
8960 packed array types, since we're going to fix-up the array
8961 type length and element bitsize a little further down. */
ad82864c 8962 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8963 result = type0;
14f9c5c9 8964 else
e9bb382b 8965 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8966 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8967 }
8968 else
8969 {
8970 int i;
8971 struct type *elt_type0;
8972
8973 elt_type0 = type0;
8974 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8975 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8976
8977 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8978 depend on the contents of the array in properly constructed
8979 debugging data. */
529cad9c
PH
8980 /* Create a fixed version of the array element type.
8981 We're not providing the address of an element here,
e1d5a0d2 8982 and thus the actual object value cannot be inspected to do
529cad9c
PH
8983 the conversion. This should not be a problem, since arrays of
8984 unconstrained objects are not allowed. In particular, all
8985 the elements of an array of a tagged type should all be of
8986 the same type specified in the debugging info. No need to
8987 consult the object tag. */
1ed6ede0
JB
8988 result =
8989 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8990
8991 elt_type0 = type0;
14f9c5c9 8992 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8993 {
8994 struct type *range_type =
28c85d6c 8995 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8996
e9bb382b 8997 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8998 result, range_type);
1ce677a4 8999 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 9000 }
d2e4a39e 9001 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 9002 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
9003 }
9004
2e6fda7d
JB
9005 /* We want to preserve the type name. This can be useful when
9006 trying to get the type name of a value that has already been
9007 printed (for instance, if the user did "print VAR; whatis $". */
9008 TYPE_NAME (result) = TYPE_NAME (type0);
9009
ad82864c 9010 if (constrained_packed_array_p)
284614f0
JB
9011 {
9012 /* So far, the resulting type has been created as if the original
9013 type was a regular (non-packed) array type. As a result, the
9014 bitsize of the array elements needs to be set again, and the array
9015 length needs to be recomputed based on that bitsize. */
9016 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
9017 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
9018
9019 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
9020 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
9021 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
9022 TYPE_LENGTH (result)++;
9023 }
9024
876cecd0 9025 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 9026 return result;
d2e4a39e 9027}
14f9c5c9
AS
9028
9029
9030/* A standard type (containing no dynamically sized components)
9031 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
9032 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 9033 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
9034 ADDRESS or in VALADDR contains these discriminants.
9035
1ed6ede0
JB
9036 If CHECK_TAG is not null, in the case of tagged types, this function
9037 attempts to locate the object's tag and use it to compute the actual
9038 type. However, when ADDRESS is null, we cannot use it to determine the
9039 location of the tag, and therefore compute the tagged type's actual type.
9040 So we return the tagged type without consulting the tag. */
529cad9c 9041
f192137b
JB
9042static struct type *
9043ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 9044 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 9045{
61ee279c 9046 type = ada_check_typedef (type);
d2e4a39e
AS
9047 switch (TYPE_CODE (type))
9048 {
9049 default:
14f9c5c9 9050 return type;
d2e4a39e 9051 case TYPE_CODE_STRUCT:
4c4b4cd2 9052 {
76a01679 9053 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
9054 struct type *fixed_record_type =
9055 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 9056
529cad9c
PH
9057 /* If STATIC_TYPE is a tagged type and we know the object's address,
9058 then we can determine its tag, and compute the object's actual
0963b4bd 9059 type from there. Note that we have to use the fixed record
1ed6ede0
JB
9060 type (the parent part of the record may have dynamic fields
9061 and the way the location of _tag is expressed may depend on
9062 them). */
529cad9c 9063
1ed6ede0 9064 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 9065 {
b50d69b5
JG
9066 struct value *tag =
9067 value_tag_from_contents_and_address
9068 (fixed_record_type,
9069 valaddr,
9070 address);
9071 struct type *real_type = type_from_tag (tag);
9072 struct value *obj =
9073 value_from_contents_and_address (fixed_record_type,
9074 valaddr,
9075 address);
9f1f738a 9076 fixed_record_type = value_type (obj);
76a01679 9077 if (real_type != NULL)
b50d69b5
JG
9078 return to_fixed_record_type
9079 (real_type, NULL,
9080 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 9081 }
4af88198
JB
9082
9083 /* Check to see if there is a parallel ___XVZ variable.
9084 If there is, then it provides the actual size of our type. */
9085 else if (ada_type_name (fixed_record_type) != NULL)
9086 {
0d5cff50 9087 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
9088 char *xvz_name
9089 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 9090 bool xvz_found = false;
4af88198
JB
9091 LONGEST size;
9092
88c15c34 9093 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
eccab96d
JB
9094 TRY
9095 {
9096 xvz_found = get_int_var_value (xvz_name, size);
9097 }
9098 CATCH (except, RETURN_MASK_ERROR)
9099 {
9100 /* We found the variable, but somehow failed to read
9101 its value. Rethrow the same error, but with a little
9102 bit more information, to help the user understand
9103 what went wrong (Eg: the variable might have been
9104 optimized out). */
9105 throw_error (except.error,
9106 _("unable to read value of %s (%s)"),
9107 xvz_name, except.message);
9108 }
9109 END_CATCH
9110
9111 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
9112 {
9113 fixed_record_type = copy_type (fixed_record_type);
9114 TYPE_LENGTH (fixed_record_type) = size;
9115
9116 /* The FIXED_RECORD_TYPE may have be a stub. We have
9117 observed this when the debugging info is STABS, and
9118 apparently it is something that is hard to fix.
9119
9120 In practice, we don't need the actual type definition
9121 at all, because the presence of the XVZ variable allows us
9122 to assume that there must be a XVS type as well, which we
9123 should be able to use later, when we need the actual type
9124 definition.
9125
9126 In the meantime, pretend that the "fixed" type we are
9127 returning is NOT a stub, because this can cause trouble
9128 when using this type to create new types targeting it.
9129 Indeed, the associated creation routines often check
9130 whether the target type is a stub and will try to replace
0963b4bd 9131 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9132 might cause the new type to have the wrong size too.
9133 Consider the case of an array, for instance, where the size
9134 of the array is computed from the number of elements in
9135 our array multiplied by the size of its element. */
9136 TYPE_STUB (fixed_record_type) = 0;
9137 }
9138 }
1ed6ede0 9139 return fixed_record_type;
4c4b4cd2 9140 }
d2e4a39e 9141 case TYPE_CODE_ARRAY:
4c4b4cd2 9142 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9143 case TYPE_CODE_UNION:
9144 if (dval == NULL)
4c4b4cd2 9145 return type;
d2e4a39e 9146 else
4c4b4cd2 9147 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9148 }
14f9c5c9
AS
9149}
9150
f192137b
JB
9151/* The same as ada_to_fixed_type_1, except that it preserves the type
9152 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9153
9154 The typedef layer needs be preserved in order to differentiate between
9155 arrays and array pointers when both types are implemented using the same
9156 fat pointer. In the array pointer case, the pointer is encoded as
9157 a typedef of the pointer type. For instance, considering:
9158
9159 type String_Access is access String;
9160 S1 : String_Access := null;
9161
9162 To the debugger, S1 is defined as a typedef of type String. But
9163 to the user, it is a pointer. So if the user tries to print S1,
9164 we should not dereference the array, but print the array address
9165 instead.
9166
9167 If we didn't preserve the typedef layer, we would lose the fact that
9168 the type is to be presented as a pointer (needs de-reference before
9169 being printed). And we would also use the source-level type name. */
f192137b
JB
9170
9171struct type *
9172ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9173 CORE_ADDR address, struct value *dval, int check_tag)
9174
9175{
9176 struct type *fixed_type =
9177 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9178
96dbd2c1
JB
9179 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9180 then preserve the typedef layer.
9181
9182 Implementation note: We can only check the main-type portion of
9183 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9184 from TYPE now returns a type that has the same instance flags
9185 as TYPE. For instance, if TYPE is a "typedef const", and its
9186 target type is a "struct", then the typedef elimination will return
9187 a "const" version of the target type. See check_typedef for more
9188 details about how the typedef layer elimination is done.
9189
9190 brobecker/2010-11-19: It seems to me that the only case where it is
9191 useful to preserve the typedef layer is when dealing with fat pointers.
9192 Perhaps, we could add a check for that and preserve the typedef layer
9193 only in that situation. But this seems unecessary so far, probably
9194 because we call check_typedef/ada_check_typedef pretty much everywhere.
9195 */
f192137b 9196 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9197 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9198 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9199 return type;
9200
9201 return fixed_type;
9202}
9203
14f9c5c9 9204/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9205 TYPE0, but based on no runtime data. */
14f9c5c9 9206
d2e4a39e
AS
9207static struct type *
9208to_static_fixed_type (struct type *type0)
14f9c5c9 9209{
d2e4a39e 9210 struct type *type;
14f9c5c9
AS
9211
9212 if (type0 == NULL)
9213 return NULL;
9214
876cecd0 9215 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9216 return type0;
9217
61ee279c 9218 type0 = ada_check_typedef (type0);
d2e4a39e 9219
14f9c5c9
AS
9220 switch (TYPE_CODE (type0))
9221 {
9222 default:
9223 return type0;
9224 case TYPE_CODE_STRUCT:
9225 type = dynamic_template_type (type0);
d2e4a39e 9226 if (type != NULL)
4c4b4cd2
PH
9227 return template_to_static_fixed_type (type);
9228 else
9229 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9230 case TYPE_CODE_UNION:
9231 type = ada_find_parallel_type (type0, "___XVU");
9232 if (type != NULL)
4c4b4cd2
PH
9233 return template_to_static_fixed_type (type);
9234 else
9235 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9236 }
9237}
9238
4c4b4cd2
PH
9239/* A static approximation of TYPE with all type wrappers removed. */
9240
d2e4a39e
AS
9241static struct type *
9242static_unwrap_type (struct type *type)
14f9c5c9
AS
9243{
9244 if (ada_is_aligner_type (type))
9245 {
61ee279c 9246 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9247 if (ada_type_name (type1) == NULL)
4c4b4cd2 9248 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9249
9250 return static_unwrap_type (type1);
9251 }
d2e4a39e 9252 else
14f9c5c9 9253 {
d2e4a39e 9254 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9255
d2e4a39e 9256 if (raw_real_type == type)
4c4b4cd2 9257 return type;
14f9c5c9 9258 else
4c4b4cd2 9259 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9260 }
9261}
9262
9263/* In some cases, incomplete and private types require
4c4b4cd2 9264 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9265 type Foo;
9266 type FooP is access Foo;
9267 V: FooP;
9268 type Foo is array ...;
4c4b4cd2 9269 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9270 cross-references to such types, we instead substitute for FooP a
9271 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9272 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9273
9274/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9275 exists, otherwise TYPE. */
9276
d2e4a39e 9277struct type *
61ee279c 9278ada_check_typedef (struct type *type)
14f9c5c9 9279{
727e3d2e
JB
9280 if (type == NULL)
9281 return NULL;
9282
720d1a40
JB
9283 /* If our type is a typedef type of a fat pointer, then we're done.
9284 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9285 what allows us to distinguish between fat pointers that represent
9286 array types, and fat pointers that represent array access types
9287 (in both cases, the compiler implements them as fat pointers). */
9288 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9289 && is_thick_pntr (ada_typedef_target_type (type)))
9290 return type;
9291
f168693b 9292 type = check_typedef (type);
14f9c5c9 9293 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9294 || !TYPE_STUB (type)
14f9c5c9
AS
9295 || TYPE_TAG_NAME (type) == NULL)
9296 return type;
d2e4a39e 9297 else
14f9c5c9 9298 {
0d5cff50 9299 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 9300 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9301
05e522ef
JB
9302 if (type1 == NULL)
9303 return type;
9304
9305 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9306 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9307 types, only for the typedef-to-array types). If that's the case,
9308 strip the typedef layer. */
9309 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9310 type1 = ada_check_typedef (type1);
9311
9312 return type1;
14f9c5c9
AS
9313 }
9314}
9315
9316/* A value representing the data at VALADDR/ADDRESS as described by
9317 type TYPE0, but with a standard (static-sized) type that correctly
9318 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9319 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9320 creation of struct values]. */
14f9c5c9 9321
4c4b4cd2
PH
9322static struct value *
9323ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9324 struct value *val0)
14f9c5c9 9325{
1ed6ede0 9326 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9327
14f9c5c9
AS
9328 if (type == type0 && val0 != NULL)
9329 return val0;
cc0e770c
JB
9330
9331 if (VALUE_LVAL (val0) != lval_memory)
9332 {
9333 /* Our value does not live in memory; it could be a convenience
9334 variable, for instance. Create a not_lval value using val0's
9335 contents. */
9336 return value_from_contents (type, value_contents (val0));
9337 }
9338
9339 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9340}
9341
9342/* A value representing VAL, but with a standard (static-sized) type
9343 that correctly describes it. Does not necessarily create a new
9344 value. */
9345
0c3acc09 9346struct value *
4c4b4cd2
PH
9347ada_to_fixed_value (struct value *val)
9348{
c48db5ca
JB
9349 val = unwrap_value (val);
9350 val = ada_to_fixed_value_create (value_type (val),
9351 value_address (val),
9352 val);
9353 return val;
14f9c5c9 9354}
d2e4a39e 9355\f
14f9c5c9 9356
14f9c5c9
AS
9357/* Attributes */
9358
4c4b4cd2
PH
9359/* Table mapping attribute numbers to names.
9360 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9361
d2e4a39e 9362static const char *attribute_names[] = {
14f9c5c9
AS
9363 "<?>",
9364
d2e4a39e 9365 "first",
14f9c5c9
AS
9366 "last",
9367 "length",
9368 "image",
14f9c5c9
AS
9369 "max",
9370 "min",
4c4b4cd2
PH
9371 "modulus",
9372 "pos",
9373 "size",
9374 "tag",
14f9c5c9 9375 "val",
14f9c5c9
AS
9376 0
9377};
9378
d2e4a39e 9379const char *
4c4b4cd2 9380ada_attribute_name (enum exp_opcode n)
14f9c5c9 9381{
4c4b4cd2
PH
9382 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9383 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9384 else
9385 return attribute_names[0];
9386}
9387
4c4b4cd2 9388/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9389
4c4b4cd2
PH
9390static LONGEST
9391pos_atr (struct value *arg)
14f9c5c9 9392{
24209737
PH
9393 struct value *val = coerce_ref (arg);
9394 struct type *type = value_type (val);
aa715135 9395 LONGEST result;
14f9c5c9 9396
d2e4a39e 9397 if (!discrete_type_p (type))
323e0a4a 9398 error (_("'POS only defined on discrete types"));
14f9c5c9 9399
aa715135
JG
9400 if (!discrete_position (type, value_as_long (val), &result))
9401 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9402
aa715135 9403 return result;
4c4b4cd2
PH
9404}
9405
9406static struct value *
3cb382c9 9407value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9408{
3cb382c9 9409 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9410}
9411
4c4b4cd2 9412/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9413
d2e4a39e
AS
9414static struct value *
9415value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9416{
d2e4a39e 9417 if (!discrete_type_p (type))
323e0a4a 9418 error (_("'VAL only defined on discrete types"));
df407dfe 9419 if (!integer_type_p (value_type (arg)))
323e0a4a 9420 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9421
9422 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9423 {
9424 long pos = value_as_long (arg);
5b4ee69b 9425
14f9c5c9 9426 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9427 error (_("argument to 'VAL out of range"));
14e75d8e 9428 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9429 }
9430 else
9431 return value_from_longest (type, value_as_long (arg));
9432}
14f9c5c9 9433\f
d2e4a39e 9434
4c4b4cd2 9435 /* Evaluation */
14f9c5c9 9436
4c4b4cd2
PH
9437/* True if TYPE appears to be an Ada character type.
9438 [At the moment, this is true only for Character and Wide_Character;
9439 It is a heuristic test that could stand improvement]. */
14f9c5c9 9440
d2e4a39e
AS
9441int
9442ada_is_character_type (struct type *type)
14f9c5c9 9443{
7b9f71f2
JB
9444 const char *name;
9445
9446 /* If the type code says it's a character, then assume it really is,
9447 and don't check any further. */
9448 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9449 return 1;
9450
9451 /* Otherwise, assume it's a character type iff it is a discrete type
9452 with a known character type name. */
9453 name = ada_type_name (type);
9454 return (name != NULL
9455 && (TYPE_CODE (type) == TYPE_CODE_INT
9456 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9457 && (strcmp (name, "character") == 0
9458 || strcmp (name, "wide_character") == 0
5a517ebd 9459 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9460 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9461}
9462
4c4b4cd2 9463/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9464
9465int
ebf56fd3 9466ada_is_string_type (struct type *type)
14f9c5c9 9467{
61ee279c 9468 type = ada_check_typedef (type);
d2e4a39e 9469 if (type != NULL
14f9c5c9 9470 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9471 && (ada_is_simple_array_type (type)
9472 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9473 && ada_array_arity (type) == 1)
9474 {
9475 struct type *elttype = ada_array_element_type (type, 1);
9476
9477 return ada_is_character_type (elttype);
9478 }
d2e4a39e 9479 else
14f9c5c9
AS
9480 return 0;
9481}
9482
5bf03f13
JB
9483/* The compiler sometimes provides a parallel XVS type for a given
9484 PAD type. Normally, it is safe to follow the PAD type directly,
9485 but older versions of the compiler have a bug that causes the offset
9486 of its "F" field to be wrong. Following that field in that case
9487 would lead to incorrect results, but this can be worked around
9488 by ignoring the PAD type and using the associated XVS type instead.
9489
9490 Set to True if the debugger should trust the contents of PAD types.
9491 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9492static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9493
9494/* True if TYPE is a struct type introduced by the compiler to force the
9495 alignment of a value. Such types have a single field with a
4c4b4cd2 9496 distinctive name. */
14f9c5c9
AS
9497
9498int
ebf56fd3 9499ada_is_aligner_type (struct type *type)
14f9c5c9 9500{
61ee279c 9501 type = ada_check_typedef (type);
714e53ab 9502
5bf03f13 9503 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9504 return 0;
9505
14f9c5c9 9506 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9507 && TYPE_NFIELDS (type) == 1
9508 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9509}
9510
9511/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9512 the parallel type. */
14f9c5c9 9513
d2e4a39e
AS
9514struct type *
9515ada_get_base_type (struct type *raw_type)
14f9c5c9 9516{
d2e4a39e
AS
9517 struct type *real_type_namer;
9518 struct type *raw_real_type;
14f9c5c9
AS
9519
9520 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9521 return raw_type;
9522
284614f0
JB
9523 if (ada_is_aligner_type (raw_type))
9524 /* The encoding specifies that we should always use the aligner type.
9525 So, even if this aligner type has an associated XVS type, we should
9526 simply ignore it.
9527
9528 According to the compiler gurus, an XVS type parallel to an aligner
9529 type may exist because of a stabs limitation. In stabs, aligner
9530 types are empty because the field has a variable-sized type, and
9531 thus cannot actually be used as an aligner type. As a result,
9532 we need the associated parallel XVS type to decode the type.
9533 Since the policy in the compiler is to not change the internal
9534 representation based on the debugging info format, we sometimes
9535 end up having a redundant XVS type parallel to the aligner type. */
9536 return raw_type;
9537
14f9c5c9 9538 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9539 if (real_type_namer == NULL
14f9c5c9
AS
9540 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9541 || TYPE_NFIELDS (real_type_namer) != 1)
9542 return raw_type;
9543
f80d3ff2
JB
9544 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9545 {
9546 /* This is an older encoding form where the base type needs to be
9547 looked up by name. We prefer the newer enconding because it is
9548 more efficient. */
9549 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9550 if (raw_real_type == NULL)
9551 return raw_type;
9552 else
9553 return raw_real_type;
9554 }
9555
9556 /* The field in our XVS type is a reference to the base type. */
9557 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9558}
14f9c5c9 9559
4c4b4cd2 9560/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9561
d2e4a39e
AS
9562struct type *
9563ada_aligned_type (struct type *type)
14f9c5c9
AS
9564{
9565 if (ada_is_aligner_type (type))
9566 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9567 else
9568 return ada_get_base_type (type);
9569}
9570
9571
9572/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9573 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9574
fc1a4b47
AC
9575const gdb_byte *
9576ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9577{
d2e4a39e 9578 if (ada_is_aligner_type (type))
14f9c5c9 9579 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9580 valaddr +
9581 TYPE_FIELD_BITPOS (type,
9582 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9583 else
9584 return valaddr;
9585}
9586
4c4b4cd2
PH
9587
9588
14f9c5c9 9589/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9590 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9591const char *
9592ada_enum_name (const char *name)
14f9c5c9 9593{
4c4b4cd2
PH
9594 static char *result;
9595 static size_t result_len = 0;
e6a959d6 9596 const char *tmp;
14f9c5c9 9597
4c4b4cd2
PH
9598 /* First, unqualify the enumeration name:
9599 1. Search for the last '.' character. If we find one, then skip
177b42fe 9600 all the preceding characters, the unqualified name starts
76a01679 9601 right after that dot.
4c4b4cd2 9602 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9603 translates dots into "__". Search forward for double underscores,
9604 but stop searching when we hit an overloading suffix, which is
9605 of the form "__" followed by digits. */
4c4b4cd2 9606
c3e5cd34
PH
9607 tmp = strrchr (name, '.');
9608 if (tmp != NULL)
4c4b4cd2
PH
9609 name = tmp + 1;
9610 else
14f9c5c9 9611 {
4c4b4cd2
PH
9612 while ((tmp = strstr (name, "__")) != NULL)
9613 {
9614 if (isdigit (tmp[2]))
9615 break;
9616 else
9617 name = tmp + 2;
9618 }
14f9c5c9
AS
9619 }
9620
9621 if (name[0] == 'Q')
9622 {
14f9c5c9 9623 int v;
5b4ee69b 9624
14f9c5c9 9625 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9626 {
9627 if (sscanf (name + 2, "%x", &v) != 1)
9628 return name;
9629 }
14f9c5c9 9630 else
4c4b4cd2 9631 return name;
14f9c5c9 9632
4c4b4cd2 9633 GROW_VECT (result, result_len, 16);
14f9c5c9 9634 if (isascii (v) && isprint (v))
88c15c34 9635 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9636 else if (name[1] == 'U')
88c15c34 9637 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9638 else
88c15c34 9639 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9640
9641 return result;
9642 }
d2e4a39e 9643 else
4c4b4cd2 9644 {
c3e5cd34
PH
9645 tmp = strstr (name, "__");
9646 if (tmp == NULL)
9647 tmp = strstr (name, "$");
9648 if (tmp != NULL)
4c4b4cd2
PH
9649 {
9650 GROW_VECT (result, result_len, tmp - name + 1);
9651 strncpy (result, name, tmp - name);
9652 result[tmp - name] = '\0';
9653 return result;
9654 }
9655
9656 return name;
9657 }
14f9c5c9
AS
9658}
9659
14f9c5c9
AS
9660/* Evaluate the subexpression of EXP starting at *POS as for
9661 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9662 expression. */
14f9c5c9 9663
d2e4a39e
AS
9664static struct value *
9665evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9666{
4b27a620 9667 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9668}
9669
9670/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9671 value it wraps. */
14f9c5c9 9672
d2e4a39e
AS
9673static struct value *
9674unwrap_value (struct value *val)
14f9c5c9 9675{
df407dfe 9676 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9677
14f9c5c9
AS
9678 if (ada_is_aligner_type (type))
9679 {
de4d072f 9680 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9681 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9682
14f9c5c9 9683 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9684 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9685
9686 return unwrap_value (v);
9687 }
d2e4a39e 9688 else
14f9c5c9 9689 {
d2e4a39e 9690 struct type *raw_real_type =
61ee279c 9691 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9692
5bf03f13
JB
9693 /* If there is no parallel XVS or XVE type, then the value is
9694 already unwrapped. Return it without further modification. */
9695 if ((type == raw_real_type)
9696 && ada_find_parallel_type (type, "___XVE") == NULL)
9697 return val;
14f9c5c9 9698
d2e4a39e 9699 return
4c4b4cd2
PH
9700 coerce_unspec_val_to_type
9701 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9702 value_address (val),
1ed6ede0 9703 NULL, 1));
14f9c5c9
AS
9704 }
9705}
d2e4a39e
AS
9706
9707static struct value *
50eff16b 9708cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9709{
50eff16b
UW
9710 struct value *scale = ada_scaling_factor (value_type (arg));
9711 arg = value_cast (value_type (scale), arg);
14f9c5c9 9712
50eff16b
UW
9713 arg = value_binop (arg, scale, BINOP_MUL);
9714 return value_cast (type, arg);
14f9c5c9
AS
9715}
9716
d2e4a39e 9717static struct value *
50eff16b 9718cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9719{
50eff16b
UW
9720 if (type == value_type (arg))
9721 return arg;
5b4ee69b 9722
50eff16b
UW
9723 struct value *scale = ada_scaling_factor (type);
9724 if (ada_is_fixed_point_type (value_type (arg)))
9725 arg = cast_from_fixed (value_type (scale), arg);
9726 else
9727 arg = value_cast (value_type (scale), arg);
9728
9729 arg = value_binop (arg, scale, BINOP_DIV);
9730 return value_cast (type, arg);
14f9c5c9
AS
9731}
9732
d99dcf51
JB
9733/* Given two array types T1 and T2, return nonzero iff both arrays
9734 contain the same number of elements. */
9735
9736static int
9737ada_same_array_size_p (struct type *t1, struct type *t2)
9738{
9739 LONGEST lo1, hi1, lo2, hi2;
9740
9741 /* Get the array bounds in order to verify that the size of
9742 the two arrays match. */
9743 if (!get_array_bounds (t1, &lo1, &hi1)
9744 || !get_array_bounds (t2, &lo2, &hi2))
9745 error (_("unable to determine array bounds"));
9746
9747 /* To make things easier for size comparison, normalize a bit
9748 the case of empty arrays by making sure that the difference
9749 between upper bound and lower bound is always -1. */
9750 if (lo1 > hi1)
9751 hi1 = lo1 - 1;
9752 if (lo2 > hi2)
9753 hi2 = lo2 - 1;
9754
9755 return (hi1 - lo1 == hi2 - lo2);
9756}
9757
9758/* Assuming that VAL is an array of integrals, and TYPE represents
9759 an array with the same number of elements, but with wider integral
9760 elements, return an array "casted" to TYPE. In practice, this
9761 means that the returned array is built by casting each element
9762 of the original array into TYPE's (wider) element type. */
9763
9764static struct value *
9765ada_promote_array_of_integrals (struct type *type, struct value *val)
9766{
9767 struct type *elt_type = TYPE_TARGET_TYPE (type);
9768 LONGEST lo, hi;
9769 struct value *res;
9770 LONGEST i;
9771
9772 /* Verify that both val and type are arrays of scalars, and
9773 that the size of val's elements is smaller than the size
9774 of type's element. */
9775 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9776 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9777 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9778 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9779 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9780 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9781
9782 if (!get_array_bounds (type, &lo, &hi))
9783 error (_("unable to determine array bounds"));
9784
9785 res = allocate_value (type);
9786
9787 /* Promote each array element. */
9788 for (i = 0; i < hi - lo + 1; i++)
9789 {
9790 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9791
9792 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9793 value_contents_all (elt), TYPE_LENGTH (elt_type));
9794 }
9795
9796 return res;
9797}
9798
4c4b4cd2
PH
9799/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9800 return the converted value. */
9801
d2e4a39e
AS
9802static struct value *
9803coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9804{
df407dfe 9805 struct type *type2 = value_type (val);
5b4ee69b 9806
14f9c5c9
AS
9807 if (type == type2)
9808 return val;
9809
61ee279c
PH
9810 type2 = ada_check_typedef (type2);
9811 type = ada_check_typedef (type);
14f9c5c9 9812
d2e4a39e
AS
9813 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9814 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9815 {
9816 val = ada_value_ind (val);
df407dfe 9817 type2 = value_type (val);
14f9c5c9
AS
9818 }
9819
d2e4a39e 9820 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9821 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9822 {
d99dcf51
JB
9823 if (!ada_same_array_size_p (type, type2))
9824 error (_("cannot assign arrays of different length"));
9825
9826 if (is_integral_type (TYPE_TARGET_TYPE (type))
9827 && is_integral_type (TYPE_TARGET_TYPE (type2))
9828 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9829 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9830 {
9831 /* Allow implicit promotion of the array elements to
9832 a wider type. */
9833 return ada_promote_array_of_integrals (type, val);
9834 }
9835
9836 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9837 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9838 error (_("Incompatible types in assignment"));
04624583 9839 deprecated_set_value_type (val, type);
14f9c5c9 9840 }
d2e4a39e 9841 return val;
14f9c5c9
AS
9842}
9843
4c4b4cd2
PH
9844static struct value *
9845ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9846{
9847 struct value *val;
9848 struct type *type1, *type2;
9849 LONGEST v, v1, v2;
9850
994b9211
AC
9851 arg1 = coerce_ref (arg1);
9852 arg2 = coerce_ref (arg2);
18af8284
JB
9853 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9854 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9855
76a01679
JB
9856 if (TYPE_CODE (type1) != TYPE_CODE_INT
9857 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9858 return value_binop (arg1, arg2, op);
9859
76a01679 9860 switch (op)
4c4b4cd2
PH
9861 {
9862 case BINOP_MOD:
9863 case BINOP_DIV:
9864 case BINOP_REM:
9865 break;
9866 default:
9867 return value_binop (arg1, arg2, op);
9868 }
9869
9870 v2 = value_as_long (arg2);
9871 if (v2 == 0)
323e0a4a 9872 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9873
9874 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9875 return value_binop (arg1, arg2, op);
9876
9877 v1 = value_as_long (arg1);
9878 switch (op)
9879 {
9880 case BINOP_DIV:
9881 v = v1 / v2;
76a01679
JB
9882 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9883 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9884 break;
9885 case BINOP_REM:
9886 v = v1 % v2;
76a01679
JB
9887 if (v * v1 < 0)
9888 v -= v2;
4c4b4cd2
PH
9889 break;
9890 default:
9891 /* Should not reach this point. */
9892 v = 0;
9893 }
9894
9895 val = allocate_value (type1);
990a07ab 9896 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9897 TYPE_LENGTH (value_type (val)),
9898 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9899 return val;
9900}
9901
9902static int
9903ada_value_equal (struct value *arg1, struct value *arg2)
9904{
df407dfe
AC
9905 if (ada_is_direct_array_type (value_type (arg1))
9906 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9907 {
79e8fcaa
JB
9908 struct type *arg1_type, *arg2_type;
9909
f58b38bf
JB
9910 /* Automatically dereference any array reference before
9911 we attempt to perform the comparison. */
9912 arg1 = ada_coerce_ref (arg1);
9913 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9914
4c4b4cd2
PH
9915 arg1 = ada_coerce_to_simple_array (arg1);
9916 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9917
9918 arg1_type = ada_check_typedef (value_type (arg1));
9919 arg2_type = ada_check_typedef (value_type (arg2));
9920
9921 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9922 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9923 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9924 /* FIXME: The following works only for types whose
76a01679
JB
9925 representations use all bits (no padding or undefined bits)
9926 and do not have user-defined equality. */
79e8fcaa
JB
9927 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9928 && memcmp (value_contents (arg1), value_contents (arg2),
9929 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9930 }
9931 return value_equal (arg1, arg2);
9932}
9933
52ce6436
PH
9934/* Total number of component associations in the aggregate starting at
9935 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9936 OP_AGGREGATE. */
52ce6436
PH
9937
9938static int
9939num_component_specs (struct expression *exp, int pc)
9940{
9941 int n, m, i;
5b4ee69b 9942
52ce6436
PH
9943 m = exp->elts[pc + 1].longconst;
9944 pc += 3;
9945 n = 0;
9946 for (i = 0; i < m; i += 1)
9947 {
9948 switch (exp->elts[pc].opcode)
9949 {
9950 default:
9951 n += 1;
9952 break;
9953 case OP_CHOICES:
9954 n += exp->elts[pc + 1].longconst;
9955 break;
9956 }
9957 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9958 }
9959 return n;
9960}
9961
9962/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9963 component of LHS (a simple array or a record), updating *POS past
9964 the expression, assuming that LHS is contained in CONTAINER. Does
9965 not modify the inferior's memory, nor does it modify LHS (unless
9966 LHS == CONTAINER). */
9967
9968static void
9969assign_component (struct value *container, struct value *lhs, LONGEST index,
9970 struct expression *exp, int *pos)
9971{
9972 struct value *mark = value_mark ();
9973 struct value *elt;
0e2da9f0 9974 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9975
0e2da9f0 9976 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9977 {
22601c15
UW
9978 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9979 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9980
52ce6436
PH
9981 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9982 }
9983 else
9984 {
9985 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9986 elt = ada_to_fixed_value (elt);
52ce6436
PH
9987 }
9988
9989 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9990 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9991 else
9992 value_assign_to_component (container, elt,
9993 ada_evaluate_subexp (NULL, exp, pos,
9994 EVAL_NORMAL));
9995
9996 value_free_to_mark (mark);
9997}
9998
9999/* Assuming that LHS represents an lvalue having a record or array
10000 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
10001 of that aggregate's value to LHS, advancing *POS past the
10002 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
10003 lvalue containing LHS (possibly LHS itself). Does not modify
10004 the inferior's memory, nor does it modify the contents of
0963b4bd 10005 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
10006
10007static struct value *
10008assign_aggregate (struct value *container,
10009 struct value *lhs, struct expression *exp,
10010 int *pos, enum noside noside)
10011{
10012 struct type *lhs_type;
10013 int n = exp->elts[*pos+1].longconst;
10014 LONGEST low_index, high_index;
10015 int num_specs;
10016 LONGEST *indices;
10017 int max_indices, num_indices;
52ce6436 10018 int i;
52ce6436
PH
10019
10020 *pos += 3;
10021 if (noside != EVAL_NORMAL)
10022 {
52ce6436
PH
10023 for (i = 0; i < n; i += 1)
10024 ada_evaluate_subexp (NULL, exp, pos, noside);
10025 return container;
10026 }
10027
10028 container = ada_coerce_ref (container);
10029 if (ada_is_direct_array_type (value_type (container)))
10030 container = ada_coerce_to_simple_array (container);
10031 lhs = ada_coerce_ref (lhs);
10032 if (!deprecated_value_modifiable (lhs))
10033 error (_("Left operand of assignment is not a modifiable lvalue."));
10034
0e2da9f0 10035 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
10036 if (ada_is_direct_array_type (lhs_type))
10037 {
10038 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 10039 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
10040 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10041 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
10042 }
10043 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10044 {
10045 low_index = 0;
10046 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
10047 }
10048 else
10049 error (_("Left-hand side must be array or record."));
10050
10051 num_specs = num_component_specs (exp, *pos - 3);
10052 max_indices = 4 * num_specs + 4;
8d749320 10053 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
10054 indices[0] = indices[1] = low_index - 1;
10055 indices[2] = indices[3] = high_index + 1;
10056 num_indices = 4;
10057
10058 for (i = 0; i < n; i += 1)
10059 {
10060 switch (exp->elts[*pos].opcode)
10061 {
1fbf5ada
JB
10062 case OP_CHOICES:
10063 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10064 &num_indices, max_indices,
10065 low_index, high_index);
10066 break;
10067 case OP_POSITIONAL:
10068 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
10069 &num_indices, max_indices,
10070 low_index, high_index);
1fbf5ada
JB
10071 break;
10072 case OP_OTHERS:
10073 if (i != n-1)
10074 error (_("Misplaced 'others' clause"));
10075 aggregate_assign_others (container, lhs, exp, pos, indices,
10076 num_indices, low_index, high_index);
10077 break;
10078 default:
10079 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
10080 }
10081 }
10082
10083 return container;
10084}
10085
10086/* Assign into the component of LHS indexed by the OP_POSITIONAL
10087 construct at *POS, updating *POS past the construct, given that
10088 the positions are relative to lower bound LOW, where HIGH is the
10089 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10090 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 10091 assign_aggregate. */
52ce6436
PH
10092static void
10093aggregate_assign_positional (struct value *container,
10094 struct value *lhs, struct expression *exp,
10095 int *pos, LONGEST *indices, int *num_indices,
10096 int max_indices, LONGEST low, LONGEST high)
10097{
10098 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10099
10100 if (ind - 1 == high)
e1d5a0d2 10101 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
10102 if (ind <= high)
10103 {
10104 add_component_interval (ind, ind, indices, num_indices, max_indices);
10105 *pos += 3;
10106 assign_component (container, lhs, ind, exp, pos);
10107 }
10108 else
10109 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10110}
10111
10112/* Assign into the components of LHS indexed by the OP_CHOICES
10113 construct at *POS, updating *POS past the construct, given that
10114 the allowable indices are LOW..HIGH. Record the indices assigned
10115 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 10116 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10117static void
10118aggregate_assign_from_choices (struct value *container,
10119 struct value *lhs, struct expression *exp,
10120 int *pos, LONGEST *indices, int *num_indices,
10121 int max_indices, LONGEST low, LONGEST high)
10122{
10123 int j;
10124 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10125 int choice_pos, expr_pc;
10126 int is_array = ada_is_direct_array_type (value_type (lhs));
10127
10128 choice_pos = *pos += 3;
10129
10130 for (j = 0; j < n_choices; j += 1)
10131 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10132 expr_pc = *pos;
10133 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10134
10135 for (j = 0; j < n_choices; j += 1)
10136 {
10137 LONGEST lower, upper;
10138 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10139
52ce6436
PH
10140 if (op == OP_DISCRETE_RANGE)
10141 {
10142 choice_pos += 1;
10143 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10144 EVAL_NORMAL));
10145 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10146 EVAL_NORMAL));
10147 }
10148 else if (is_array)
10149 {
10150 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10151 EVAL_NORMAL));
10152 upper = lower;
10153 }
10154 else
10155 {
10156 int ind;
0d5cff50 10157 const char *name;
5b4ee69b 10158
52ce6436
PH
10159 switch (op)
10160 {
10161 case OP_NAME:
10162 name = &exp->elts[choice_pos + 2].string;
10163 break;
10164 case OP_VAR_VALUE:
10165 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10166 break;
10167 default:
10168 error (_("Invalid record component association."));
10169 }
10170 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10171 ind = 0;
10172 if (! find_struct_field (name, value_type (lhs), 0,
10173 NULL, NULL, NULL, NULL, &ind))
10174 error (_("Unknown component name: %s."), name);
10175 lower = upper = ind;
10176 }
10177
10178 if (lower <= upper && (lower < low || upper > high))
10179 error (_("Index in component association out of bounds."));
10180
10181 add_component_interval (lower, upper, indices, num_indices,
10182 max_indices);
10183 while (lower <= upper)
10184 {
10185 int pos1;
5b4ee69b 10186
52ce6436
PH
10187 pos1 = expr_pc;
10188 assign_component (container, lhs, lower, exp, &pos1);
10189 lower += 1;
10190 }
10191 }
10192}
10193
10194/* Assign the value of the expression in the OP_OTHERS construct in
10195 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10196 have not been previously assigned. The index intervals already assigned
10197 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10198 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10199static void
10200aggregate_assign_others (struct value *container,
10201 struct value *lhs, struct expression *exp,
10202 int *pos, LONGEST *indices, int num_indices,
10203 LONGEST low, LONGEST high)
10204{
10205 int i;
5ce64950 10206 int expr_pc = *pos + 1;
52ce6436
PH
10207
10208 for (i = 0; i < num_indices - 2; i += 2)
10209 {
10210 LONGEST ind;
5b4ee69b 10211
52ce6436
PH
10212 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10213 {
5ce64950 10214 int localpos;
5b4ee69b 10215
5ce64950
MS
10216 localpos = expr_pc;
10217 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10218 }
10219 }
10220 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10221}
10222
10223/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10224 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10225 modifying *SIZE as needed. It is an error if *SIZE exceeds
10226 MAX_SIZE. The resulting intervals do not overlap. */
10227static void
10228add_component_interval (LONGEST low, LONGEST high,
10229 LONGEST* indices, int *size, int max_size)
10230{
10231 int i, j;
5b4ee69b 10232
52ce6436
PH
10233 for (i = 0; i < *size; i += 2) {
10234 if (high >= indices[i] && low <= indices[i + 1])
10235 {
10236 int kh;
5b4ee69b 10237
52ce6436
PH
10238 for (kh = i + 2; kh < *size; kh += 2)
10239 if (high < indices[kh])
10240 break;
10241 if (low < indices[i])
10242 indices[i] = low;
10243 indices[i + 1] = indices[kh - 1];
10244 if (high > indices[i + 1])
10245 indices[i + 1] = high;
10246 memcpy (indices + i + 2, indices + kh, *size - kh);
10247 *size -= kh - i - 2;
10248 return;
10249 }
10250 else if (high < indices[i])
10251 break;
10252 }
10253
10254 if (*size == max_size)
10255 error (_("Internal error: miscounted aggregate components."));
10256 *size += 2;
10257 for (j = *size-1; j >= i+2; j -= 1)
10258 indices[j] = indices[j - 2];
10259 indices[i] = low;
10260 indices[i + 1] = high;
10261}
10262
6e48bd2c
JB
10263/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10264 is different. */
10265
10266static struct value *
b7e22850 10267ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10268{
10269 if (type == ada_check_typedef (value_type (arg2)))
10270 return arg2;
10271
10272 if (ada_is_fixed_point_type (type))
10273 return (cast_to_fixed (type, arg2));
10274
10275 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10276 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10277
10278 return value_cast (type, arg2);
10279}
10280
284614f0
JB
10281/* Evaluating Ada expressions, and printing their result.
10282 ------------------------------------------------------
10283
21649b50
JB
10284 1. Introduction:
10285 ----------------
10286
284614f0
JB
10287 We usually evaluate an Ada expression in order to print its value.
10288 We also evaluate an expression in order to print its type, which
10289 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10290 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10291 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10292 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10293 similar.
10294
10295 Evaluating expressions is a little more complicated for Ada entities
10296 than it is for entities in languages such as C. The main reason for
10297 this is that Ada provides types whose definition might be dynamic.
10298 One example of such types is variant records. Or another example
10299 would be an array whose bounds can only be known at run time.
10300
10301 The following description is a general guide as to what should be
10302 done (and what should NOT be done) in order to evaluate an expression
10303 involving such types, and when. This does not cover how the semantic
10304 information is encoded by GNAT as this is covered separatly. For the
10305 document used as the reference for the GNAT encoding, see exp_dbug.ads
10306 in the GNAT sources.
10307
10308 Ideally, we should embed each part of this description next to its
10309 associated code. Unfortunately, the amount of code is so vast right
10310 now that it's hard to see whether the code handling a particular
10311 situation might be duplicated or not. One day, when the code is
10312 cleaned up, this guide might become redundant with the comments
10313 inserted in the code, and we might want to remove it.
10314
21649b50
JB
10315 2. ``Fixing'' an Entity, the Simple Case:
10316 -----------------------------------------
10317
284614f0
JB
10318 When evaluating Ada expressions, the tricky issue is that they may
10319 reference entities whose type contents and size are not statically
10320 known. Consider for instance a variant record:
10321
10322 type Rec (Empty : Boolean := True) is record
10323 case Empty is
10324 when True => null;
10325 when False => Value : Integer;
10326 end case;
10327 end record;
10328 Yes : Rec := (Empty => False, Value => 1);
10329 No : Rec := (empty => True);
10330
10331 The size and contents of that record depends on the value of the
10332 descriminant (Rec.Empty). At this point, neither the debugging
10333 information nor the associated type structure in GDB are able to
10334 express such dynamic types. So what the debugger does is to create
10335 "fixed" versions of the type that applies to the specific object.
10336 We also informally refer to this opperation as "fixing" an object,
10337 which means creating its associated fixed type.
10338
10339 Example: when printing the value of variable "Yes" above, its fixed
10340 type would look like this:
10341
10342 type Rec is record
10343 Empty : Boolean;
10344 Value : Integer;
10345 end record;
10346
10347 On the other hand, if we printed the value of "No", its fixed type
10348 would become:
10349
10350 type Rec is record
10351 Empty : Boolean;
10352 end record;
10353
10354 Things become a little more complicated when trying to fix an entity
10355 with a dynamic type that directly contains another dynamic type,
10356 such as an array of variant records, for instance. There are
10357 two possible cases: Arrays, and records.
10358
21649b50
JB
10359 3. ``Fixing'' Arrays:
10360 ---------------------
10361
10362 The type structure in GDB describes an array in terms of its bounds,
10363 and the type of its elements. By design, all elements in the array
10364 have the same type and we cannot represent an array of variant elements
10365 using the current type structure in GDB. When fixing an array,
10366 we cannot fix the array element, as we would potentially need one
10367 fixed type per element of the array. As a result, the best we can do
10368 when fixing an array is to produce an array whose bounds and size
10369 are correct (allowing us to read it from memory), but without having
10370 touched its element type. Fixing each element will be done later,
10371 when (if) necessary.
10372
10373 Arrays are a little simpler to handle than records, because the same
10374 amount of memory is allocated for each element of the array, even if
1b536f04 10375 the amount of space actually used by each element differs from element
21649b50 10376 to element. Consider for instance the following array of type Rec:
284614f0
JB
10377
10378 type Rec_Array is array (1 .. 2) of Rec;
10379
1b536f04
JB
10380 The actual amount of memory occupied by each element might be different
10381 from element to element, depending on the value of their discriminant.
21649b50 10382 But the amount of space reserved for each element in the array remains
1b536f04 10383 fixed regardless. So we simply need to compute that size using
21649b50
JB
10384 the debugging information available, from which we can then determine
10385 the array size (we multiply the number of elements of the array by
10386 the size of each element).
10387
10388 The simplest case is when we have an array of a constrained element
10389 type. For instance, consider the following type declarations:
10390
10391 type Bounded_String (Max_Size : Integer) is
10392 Length : Integer;
10393 Buffer : String (1 .. Max_Size);
10394 end record;
10395 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10396
10397 In this case, the compiler describes the array as an array of
10398 variable-size elements (identified by its XVS suffix) for which
10399 the size can be read in the parallel XVZ variable.
10400
10401 In the case of an array of an unconstrained element type, the compiler
10402 wraps the array element inside a private PAD type. This type should not
10403 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10404 that we also use the adjective "aligner" in our code to designate
10405 these wrapper types.
10406
1b536f04 10407 In some cases, the size allocated for each element is statically
21649b50
JB
10408 known. In that case, the PAD type already has the correct size,
10409 and the array element should remain unfixed.
10410
10411 But there are cases when this size is not statically known.
10412 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10413
10414 type Dynamic is array (1 .. Five) of Integer;
10415 type Wrapper (Has_Length : Boolean := False) is record
10416 Data : Dynamic;
10417 case Has_Length is
10418 when True => Length : Integer;
10419 when False => null;
10420 end case;
10421 end record;
10422 type Wrapper_Array is array (1 .. 2) of Wrapper;
10423
10424 Hello : Wrapper_Array := (others => (Has_Length => True,
10425 Data => (others => 17),
10426 Length => 1));
10427
10428
10429 The debugging info would describe variable Hello as being an
10430 array of a PAD type. The size of that PAD type is not statically
10431 known, but can be determined using a parallel XVZ variable.
10432 In that case, a copy of the PAD type with the correct size should
10433 be used for the fixed array.
10434
21649b50
JB
10435 3. ``Fixing'' record type objects:
10436 ----------------------------------
10437
10438 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10439 record types. In this case, in order to compute the associated
10440 fixed type, we need to determine the size and offset of each of
10441 its components. This, in turn, requires us to compute the fixed
10442 type of each of these components.
10443
10444 Consider for instance the example:
10445
10446 type Bounded_String (Max_Size : Natural) is record
10447 Str : String (1 .. Max_Size);
10448 Length : Natural;
10449 end record;
10450 My_String : Bounded_String (Max_Size => 10);
10451
10452 In that case, the position of field "Length" depends on the size
10453 of field Str, which itself depends on the value of the Max_Size
21649b50 10454 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10455 we need to fix the type of field Str. Therefore, fixing a variant
10456 record requires us to fix each of its components.
10457
10458 However, if a component does not have a dynamic size, the component
10459 should not be fixed. In particular, fields that use a PAD type
10460 should not fixed. Here is an example where this might happen
10461 (assuming type Rec above):
10462
10463 type Container (Big : Boolean) is record
10464 First : Rec;
10465 After : Integer;
10466 case Big is
10467 when True => Another : Integer;
10468 when False => null;
10469 end case;
10470 end record;
10471 My_Container : Container := (Big => False,
10472 First => (Empty => True),
10473 After => 42);
10474
10475 In that example, the compiler creates a PAD type for component First,
10476 whose size is constant, and then positions the component After just
10477 right after it. The offset of component After is therefore constant
10478 in this case.
10479
10480 The debugger computes the position of each field based on an algorithm
10481 that uses, among other things, the actual position and size of the field
21649b50
JB
10482 preceding it. Let's now imagine that the user is trying to print
10483 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10484 end up computing the offset of field After based on the size of the
10485 fixed version of field First. And since in our example First has
10486 only one actual field, the size of the fixed type is actually smaller
10487 than the amount of space allocated to that field, and thus we would
10488 compute the wrong offset of field After.
10489
21649b50
JB
10490 To make things more complicated, we need to watch out for dynamic
10491 components of variant records (identified by the ___XVL suffix in
10492 the component name). Even if the target type is a PAD type, the size
10493 of that type might not be statically known. So the PAD type needs
10494 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10495 we might end up with the wrong size for our component. This can be
10496 observed with the following type declarations:
284614f0
JB
10497
10498 type Octal is new Integer range 0 .. 7;
10499 type Octal_Array is array (Positive range <>) of Octal;
10500 pragma Pack (Octal_Array);
10501
10502 type Octal_Buffer (Size : Positive) is record
10503 Buffer : Octal_Array (1 .. Size);
10504 Length : Integer;
10505 end record;
10506
10507 In that case, Buffer is a PAD type whose size is unset and needs
10508 to be computed by fixing the unwrapped type.
10509
21649b50
JB
10510 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10511 ----------------------------------------------------------
10512
10513 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10514 thus far, be actually fixed?
10515
10516 The answer is: Only when referencing that element. For instance
10517 when selecting one component of a record, this specific component
10518 should be fixed at that point in time. Or when printing the value
10519 of a record, each component should be fixed before its value gets
10520 printed. Similarly for arrays, the element of the array should be
10521 fixed when printing each element of the array, or when extracting
10522 one element out of that array. On the other hand, fixing should
10523 not be performed on the elements when taking a slice of an array!
10524
31432a67 10525 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10526 size of each field is that we end up also miscomputing the size
10527 of the containing type. This can have adverse results when computing
10528 the value of an entity. GDB fetches the value of an entity based
10529 on the size of its type, and thus a wrong size causes GDB to fetch
10530 the wrong amount of memory. In the case where the computed size is
10531 too small, GDB fetches too little data to print the value of our
31432a67 10532 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10533 past the buffer containing the data =:-o. */
10534
ced9779b
JB
10535/* Evaluate a subexpression of EXP, at index *POS, and return a value
10536 for that subexpression cast to TO_TYPE. Advance *POS over the
10537 subexpression. */
10538
10539static value *
10540ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10541 enum noside noside, struct type *to_type)
10542{
10543 int pc = *pos;
10544
10545 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10546 || exp->elts[pc].opcode == OP_VAR_VALUE)
10547 {
10548 (*pos) += 4;
10549
10550 value *val;
10551 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10552 {
10553 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10554 return value_zero (to_type, not_lval);
10555
10556 val = evaluate_var_msym_value (noside,
10557 exp->elts[pc + 1].objfile,
10558 exp->elts[pc + 2].msymbol);
10559 }
10560 else
10561 val = evaluate_var_value (noside,
10562 exp->elts[pc + 1].block,
10563 exp->elts[pc + 2].symbol);
10564
10565 if (noside == EVAL_SKIP)
10566 return eval_skip_value (exp);
10567
10568 val = ada_value_cast (to_type, val);
10569
10570 /* Follow the Ada language semantics that do not allow taking
10571 an address of the result of a cast (view conversion in Ada). */
10572 if (VALUE_LVAL (val) == lval_memory)
10573 {
10574 if (value_lazy (val))
10575 value_fetch_lazy (val);
10576 VALUE_LVAL (val) = not_lval;
10577 }
10578 return val;
10579 }
10580
10581 value *val = evaluate_subexp (to_type, exp, pos, noside);
10582 if (noside == EVAL_SKIP)
10583 return eval_skip_value (exp);
10584 return ada_value_cast (to_type, val);
10585}
10586
284614f0
JB
10587/* Implement the evaluate_exp routine in the exp_descriptor structure
10588 for the Ada language. */
10589
52ce6436 10590static struct value *
ebf56fd3 10591ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10592 int *pos, enum noside noside)
14f9c5c9
AS
10593{
10594 enum exp_opcode op;
b5385fc0 10595 int tem;
14f9c5c9 10596 int pc;
5ec18f2b 10597 int preeval_pos;
14f9c5c9
AS
10598 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10599 struct type *type;
52ce6436 10600 int nargs, oplen;
d2e4a39e 10601 struct value **argvec;
14f9c5c9 10602
d2e4a39e
AS
10603 pc = *pos;
10604 *pos += 1;
14f9c5c9
AS
10605 op = exp->elts[pc].opcode;
10606
d2e4a39e 10607 switch (op)
14f9c5c9
AS
10608 {
10609 default:
10610 *pos -= 1;
6e48bd2c 10611 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10612
10613 if (noside == EVAL_NORMAL)
10614 arg1 = unwrap_value (arg1);
6e48bd2c 10615
edd079d9 10616 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10617 then we need to perform the conversion manually, because
10618 evaluate_subexp_standard doesn't do it. This conversion is
10619 necessary in Ada because the different kinds of float/fixed
10620 types in Ada have different representations.
10621
10622 Similarly, we need to perform the conversion from OP_LONG
10623 ourselves. */
edd079d9 10624 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10625 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10626
10627 return arg1;
4c4b4cd2
PH
10628
10629 case OP_STRING:
10630 {
76a01679 10631 struct value *result;
5b4ee69b 10632
76a01679
JB
10633 *pos -= 1;
10634 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10635 /* The result type will have code OP_STRING, bashed there from
10636 OP_ARRAY. Bash it back. */
df407dfe
AC
10637 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10638 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10639 return result;
4c4b4cd2 10640 }
14f9c5c9
AS
10641
10642 case UNOP_CAST:
10643 (*pos) += 2;
10644 type = exp->elts[pc + 1].type;
ced9779b 10645 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10646
4c4b4cd2
PH
10647 case UNOP_QUAL:
10648 (*pos) += 2;
10649 type = exp->elts[pc + 1].type;
10650 return ada_evaluate_subexp (type, exp, pos, noside);
10651
14f9c5c9
AS
10652 case BINOP_ASSIGN:
10653 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10654 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10655 {
10656 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10657 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10658 return arg1;
10659 return ada_value_assign (arg1, arg1);
10660 }
003f3813
JB
10661 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10662 except if the lhs of our assignment is a convenience variable.
10663 In the case of assigning to a convenience variable, the lhs
10664 should be exactly the result of the evaluation of the rhs. */
10665 type = value_type (arg1);
10666 if (VALUE_LVAL (arg1) == lval_internalvar)
10667 type = NULL;
10668 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10669 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10670 return arg1;
df407dfe
AC
10671 if (ada_is_fixed_point_type (value_type (arg1)))
10672 arg2 = cast_to_fixed (value_type (arg1), arg2);
10673 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10674 error
323e0a4a 10675 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10676 else
df407dfe 10677 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10678 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10679
10680 case BINOP_ADD:
10681 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10682 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10683 if (noside == EVAL_SKIP)
4c4b4cd2 10684 goto nosideret;
2ac8a782
JB
10685 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10686 return (value_from_longest
10687 (value_type (arg1),
10688 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10689 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10690 return (value_from_longest
10691 (value_type (arg2),
10692 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10693 if ((ada_is_fixed_point_type (value_type (arg1))
10694 || ada_is_fixed_point_type (value_type (arg2)))
10695 && value_type (arg1) != value_type (arg2))
323e0a4a 10696 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10697 /* Do the addition, and cast the result to the type of the first
10698 argument. We cannot cast the result to a reference type, so if
10699 ARG1 is a reference type, find its underlying type. */
10700 type = value_type (arg1);
10701 while (TYPE_CODE (type) == TYPE_CODE_REF)
10702 type = TYPE_TARGET_TYPE (type);
f44316fa 10703 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10704 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10705
10706 case BINOP_SUB:
10707 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10708 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10709 if (noside == EVAL_SKIP)
4c4b4cd2 10710 goto nosideret;
2ac8a782
JB
10711 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10712 return (value_from_longest
10713 (value_type (arg1),
10714 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10715 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10716 return (value_from_longest
10717 (value_type (arg2),
10718 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10719 if ((ada_is_fixed_point_type (value_type (arg1))
10720 || ada_is_fixed_point_type (value_type (arg2)))
10721 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10722 error (_("Operands of fixed-point subtraction "
10723 "must have the same type"));
b7789565
JB
10724 /* Do the substraction, and cast the result to the type of the first
10725 argument. We cannot cast the result to a reference type, so if
10726 ARG1 is a reference type, find its underlying type. */
10727 type = value_type (arg1);
10728 while (TYPE_CODE (type) == TYPE_CODE_REF)
10729 type = TYPE_TARGET_TYPE (type);
f44316fa 10730 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10731 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10732
10733 case BINOP_MUL:
10734 case BINOP_DIV:
e1578042
JB
10735 case BINOP_REM:
10736 case BINOP_MOD:
14f9c5c9
AS
10737 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10738 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10739 if (noside == EVAL_SKIP)
4c4b4cd2 10740 goto nosideret;
e1578042 10741 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10742 {
10743 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10744 return value_zero (value_type (arg1), not_lval);
10745 }
14f9c5c9 10746 else
4c4b4cd2 10747 {
a53b7a21 10748 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10749 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10750 arg1 = cast_from_fixed (type, arg1);
df407dfe 10751 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10752 arg2 = cast_from_fixed (type, arg2);
f44316fa 10753 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10754 return ada_value_binop (arg1, arg2, op);
10755 }
10756
4c4b4cd2
PH
10757 case BINOP_EQUAL:
10758 case BINOP_NOTEQUAL:
14f9c5c9 10759 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10760 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10761 if (noside == EVAL_SKIP)
76a01679 10762 goto nosideret;
4c4b4cd2 10763 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10764 tem = 0;
4c4b4cd2 10765 else
f44316fa
UW
10766 {
10767 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10768 tem = ada_value_equal (arg1, arg2);
10769 }
4c4b4cd2 10770 if (op == BINOP_NOTEQUAL)
76a01679 10771 tem = !tem;
fbb06eb1
UW
10772 type = language_bool_type (exp->language_defn, exp->gdbarch);
10773 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10774
10775 case UNOP_NEG:
10776 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10777 if (noside == EVAL_SKIP)
10778 goto nosideret;
df407dfe
AC
10779 else if (ada_is_fixed_point_type (value_type (arg1)))
10780 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10781 else
f44316fa
UW
10782 {
10783 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10784 return value_neg (arg1);
10785 }
4c4b4cd2 10786
2330c6c6
JB
10787 case BINOP_LOGICAL_AND:
10788 case BINOP_LOGICAL_OR:
10789 case UNOP_LOGICAL_NOT:
000d5124
JB
10790 {
10791 struct value *val;
10792
10793 *pos -= 1;
10794 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10795 type = language_bool_type (exp->language_defn, exp->gdbarch);
10796 return value_cast (type, val);
000d5124 10797 }
2330c6c6
JB
10798
10799 case BINOP_BITWISE_AND:
10800 case BINOP_BITWISE_IOR:
10801 case BINOP_BITWISE_XOR:
000d5124
JB
10802 {
10803 struct value *val;
10804
10805 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10806 *pos = pc;
10807 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10808
10809 return value_cast (value_type (arg1), val);
10810 }
2330c6c6 10811
14f9c5c9
AS
10812 case OP_VAR_VALUE:
10813 *pos -= 1;
6799def4 10814
14f9c5c9 10815 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10816 {
10817 *pos += 4;
10818 goto nosideret;
10819 }
da5c522f
JB
10820
10821 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10822 /* Only encountered when an unresolved symbol occurs in a
10823 context other than a function call, in which case, it is
52ce6436 10824 invalid. */
323e0a4a 10825 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10826 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10827
10828 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10829 {
0c1f74cf 10830 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10831 /* Check to see if this is a tagged type. We also need to handle
10832 the case where the type is a reference to a tagged type, but
10833 we have to be careful to exclude pointers to tagged types.
10834 The latter should be shown as usual (as a pointer), whereas
10835 a reference should mostly be transparent to the user. */
10836 if (ada_is_tagged_type (type, 0)
023db19c 10837 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10838 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10839 {
10840 /* Tagged types are a little special in the fact that the real
10841 type is dynamic and can only be determined by inspecting the
10842 object's tag. This means that we need to get the object's
10843 value first (EVAL_NORMAL) and then extract the actual object
10844 type from its tag.
10845
10846 Note that we cannot skip the final step where we extract
10847 the object type from its tag, because the EVAL_NORMAL phase
10848 results in dynamic components being resolved into fixed ones.
10849 This can cause problems when trying to print the type
10850 description of tagged types whose parent has a dynamic size:
10851 We use the type name of the "_parent" component in order
10852 to print the name of the ancestor type in the type description.
10853 If that component had a dynamic size, the resolution into
10854 a fixed type would result in the loss of that type name,
10855 thus preventing us from printing the name of the ancestor
10856 type in the type description. */
10857 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10858
10859 if (TYPE_CODE (type) != TYPE_CODE_REF)
10860 {
10861 struct type *actual_type;
10862
10863 actual_type = type_from_tag (ada_value_tag (arg1));
10864 if (actual_type == NULL)
10865 /* If, for some reason, we were unable to determine
10866 the actual type from the tag, then use the static
10867 approximation that we just computed as a fallback.
10868 This can happen if the debugging information is
10869 incomplete, for instance. */
10870 actual_type = type;
10871 return value_zero (actual_type, not_lval);
10872 }
10873 else
10874 {
10875 /* In the case of a ref, ada_coerce_ref takes care
10876 of determining the actual type. But the evaluation
10877 should return a ref as it should be valid to ask
10878 for its address; so rebuild a ref after coerce. */
10879 arg1 = ada_coerce_ref (arg1);
a65cfae5 10880 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10881 }
10882 }
0c1f74cf 10883
84754697
JB
10884 /* Records and unions for which GNAT encodings have been
10885 generated need to be statically fixed as well.
10886 Otherwise, non-static fixing produces a type where
10887 all dynamic properties are removed, which prevents "ptype"
10888 from being able to completely describe the type.
10889 For instance, a case statement in a variant record would be
10890 replaced by the relevant components based on the actual
10891 value of the discriminants. */
10892 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10893 && dynamic_template_type (type) != NULL)
10894 || (TYPE_CODE (type) == TYPE_CODE_UNION
10895 && ada_find_parallel_type (type, "___XVU") != NULL))
10896 {
10897 *pos += 4;
10898 return value_zero (to_static_fixed_type (type), not_lval);
10899 }
4c4b4cd2 10900 }
da5c522f
JB
10901
10902 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10903 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10904
10905 case OP_FUNCALL:
10906 (*pos) += 2;
10907
10908 /* Allocate arg vector, including space for the function to be
10909 called in argvec[0] and a terminating NULL. */
10910 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10911 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10912
10913 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10914 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10915 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10916 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10917 else
10918 {
10919 for (tem = 0; tem <= nargs; tem += 1)
10920 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10921 argvec[tem] = 0;
10922
10923 if (noside == EVAL_SKIP)
10924 goto nosideret;
10925 }
10926
ad82864c
JB
10927 if (ada_is_constrained_packed_array_type
10928 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10929 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10930 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10931 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10932 /* This is a packed array that has already been fixed, and
10933 therefore already coerced to a simple array. Nothing further
10934 to do. */
10935 ;
e6c2c623
PMR
10936 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10937 {
10938 /* Make sure we dereference references so that all the code below
10939 feels like it's really handling the referenced value. Wrapping
10940 types (for alignment) may be there, so make sure we strip them as
10941 well. */
10942 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10943 }
10944 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10945 && VALUE_LVAL (argvec[0]) == lval_memory)
10946 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10947
df407dfe 10948 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10949
10950 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10951 them. So, if this is an array typedef (encoding use for array
10952 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10953 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10954 type = ada_typedef_target_type (type);
10955
4c4b4cd2
PH
10956 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10957 {
61ee279c 10958 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10959 {
10960 case TYPE_CODE_FUNC:
61ee279c 10961 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10962 break;
10963 case TYPE_CODE_ARRAY:
10964 break;
10965 case TYPE_CODE_STRUCT:
10966 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10967 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10968 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10969 break;
10970 default:
323e0a4a 10971 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10972 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10973 break;
10974 }
10975 }
10976
10977 switch (TYPE_CODE (type))
10978 {
10979 case TYPE_CODE_FUNC:
10980 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10981 {
7022349d
PA
10982 if (TYPE_TARGET_TYPE (type) == NULL)
10983 error_call_unknown_return_type (NULL);
10984 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10985 }
7022349d 10986 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
c8ea1972
PH
10987 case TYPE_CODE_INTERNAL_FUNCTION:
10988 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10989 /* We don't know anything about what the internal
10990 function might return, but we have to return
10991 something. */
10992 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10993 not_lval);
10994 else
10995 return call_internal_function (exp->gdbarch, exp->language_defn,
10996 argvec[0], nargs, argvec + 1);
10997
4c4b4cd2
PH
10998 case TYPE_CODE_STRUCT:
10999 {
11000 int arity;
11001
4c4b4cd2
PH
11002 arity = ada_array_arity (type);
11003 type = ada_array_element_type (type, nargs);
11004 if (type == NULL)
323e0a4a 11005 error (_("cannot subscript or call a record"));
4c4b4cd2 11006 if (arity != nargs)
323e0a4a 11007 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 11008 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 11009 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
11010 return
11011 unwrap_value (ada_value_subscript
11012 (argvec[0], nargs, argvec + 1));
11013 }
11014 case TYPE_CODE_ARRAY:
11015 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11016 {
11017 type = ada_array_element_type (type, nargs);
11018 if (type == NULL)
323e0a4a 11019 error (_("element type of array unknown"));
4c4b4cd2 11020 else
0a07e705 11021 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
11022 }
11023 return
11024 unwrap_value (ada_value_subscript
11025 (ada_coerce_to_simple_array (argvec[0]),
11026 nargs, argvec + 1));
11027 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
11028 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11029 {
deede10c 11030 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
11031 type = ada_array_element_type (type, nargs);
11032 if (type == NULL)
323e0a4a 11033 error (_("element type of array unknown"));
4c4b4cd2 11034 else
0a07e705 11035 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
11036 }
11037 return
deede10c
JB
11038 unwrap_value (ada_value_ptr_subscript (argvec[0],
11039 nargs, argvec + 1));
4c4b4cd2
PH
11040
11041 default:
e1d5a0d2
PH
11042 error (_("Attempt to index or call something other than an "
11043 "array or function"));
4c4b4cd2
PH
11044 }
11045
11046 case TERNOP_SLICE:
11047 {
11048 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11049 struct value *low_bound_val =
11050 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
11051 struct value *high_bound_val =
11052 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11053 LONGEST low_bound;
11054 LONGEST high_bound;
5b4ee69b 11055
994b9211
AC
11056 low_bound_val = coerce_ref (low_bound_val);
11057 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
11058 low_bound = value_as_long (low_bound_val);
11059 high_bound = value_as_long (high_bound_val);
963a6417 11060
4c4b4cd2
PH
11061 if (noside == EVAL_SKIP)
11062 goto nosideret;
11063
4c4b4cd2
PH
11064 /* If this is a reference to an aligner type, then remove all
11065 the aligners. */
df407dfe
AC
11066 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11067 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11068 TYPE_TARGET_TYPE (value_type (array)) =
11069 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 11070
ad82864c 11071 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 11072 error (_("cannot slice a packed array"));
4c4b4cd2
PH
11073
11074 /* If this is a reference to an array or an array lvalue,
11075 convert to a pointer. */
df407dfe
AC
11076 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11077 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
11078 && VALUE_LVAL (array) == lval_memory))
11079 array = value_addr (array);
11080
1265e4aa 11081 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 11082 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 11083 (value_type (array))))
0b5d8877 11084 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
11085
11086 array = ada_coerce_to_simple_array_ptr (array);
11087
714e53ab
PH
11088 /* If we have more than one level of pointer indirection,
11089 dereference the value until we get only one level. */
df407dfe
AC
11090 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11091 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
11092 == TYPE_CODE_PTR))
11093 array = value_ind (array);
11094
11095 /* Make sure we really do have an array type before going further,
11096 to avoid a SEGV when trying to get the index type or the target
11097 type later down the road if the debug info generated by
11098 the compiler is incorrect or incomplete. */
df407dfe 11099 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 11100 error (_("cannot take slice of non-array"));
714e53ab 11101
828292f2
JB
11102 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11103 == TYPE_CODE_PTR)
4c4b4cd2 11104 {
828292f2
JB
11105 struct type *type0 = ada_check_typedef (value_type (array));
11106
0b5d8877 11107 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 11108 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
11109 else
11110 {
11111 struct type *arr_type0 =
828292f2 11112 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 11113
f5938064
JG
11114 return ada_value_slice_from_ptr (array, arr_type0,
11115 longest_to_int (low_bound),
11116 longest_to_int (high_bound));
4c4b4cd2
PH
11117 }
11118 }
11119 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11120 return array;
11121 else if (high_bound < low_bound)
df407dfe 11122 return empty_array (value_type (array), low_bound);
4c4b4cd2 11123 else
529cad9c
PH
11124 return ada_value_slice (array, longest_to_int (low_bound),
11125 longest_to_int (high_bound));
4c4b4cd2 11126 }
14f9c5c9 11127
4c4b4cd2
PH
11128 case UNOP_IN_RANGE:
11129 (*pos) += 2;
11130 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 11131 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 11132
14f9c5c9 11133 if (noside == EVAL_SKIP)
4c4b4cd2 11134 goto nosideret;
14f9c5c9 11135
4c4b4cd2
PH
11136 switch (TYPE_CODE (type))
11137 {
11138 default:
e1d5a0d2
PH
11139 lim_warning (_("Membership test incompletely implemented; "
11140 "always returns true"));
fbb06eb1
UW
11141 type = language_bool_type (exp->language_defn, exp->gdbarch);
11142 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
11143
11144 case TYPE_CODE_RANGE:
030b4912
UW
11145 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11146 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
11147 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11148 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
11149 type = language_bool_type (exp->language_defn, exp->gdbarch);
11150 return
11151 value_from_longest (type,
4c4b4cd2
PH
11152 (value_less (arg1, arg3)
11153 || value_equal (arg1, arg3))
11154 && (value_less (arg2, arg1)
11155 || value_equal (arg2, arg1)));
11156 }
11157
11158 case BINOP_IN_BOUNDS:
14f9c5c9 11159 (*pos) += 2;
4c4b4cd2
PH
11160 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11161 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11162
4c4b4cd2
PH
11163 if (noside == EVAL_SKIP)
11164 goto nosideret;
14f9c5c9 11165
4c4b4cd2 11166 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
11167 {
11168 type = language_bool_type (exp->language_defn, exp->gdbarch);
11169 return value_zero (type, not_lval);
11170 }
14f9c5c9 11171
4c4b4cd2 11172 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11173
1eea4ebd
UW
11174 type = ada_index_type (value_type (arg2), tem, "range");
11175 if (!type)
11176 type = value_type (arg1);
14f9c5c9 11177
1eea4ebd
UW
11178 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11179 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11180
f44316fa
UW
11181 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11182 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11183 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11184 return
fbb06eb1 11185 value_from_longest (type,
4c4b4cd2
PH
11186 (value_less (arg1, arg3)
11187 || value_equal (arg1, arg3))
11188 && (value_less (arg2, arg1)
11189 || value_equal (arg2, arg1)));
11190
11191 case TERNOP_IN_RANGE:
11192 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11193 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11194 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11195
11196 if (noside == EVAL_SKIP)
11197 goto nosideret;
11198
f44316fa
UW
11199 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11200 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11201 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11202 return
fbb06eb1 11203 value_from_longest (type,
4c4b4cd2
PH
11204 (value_less (arg1, arg3)
11205 || value_equal (arg1, arg3))
11206 && (value_less (arg2, arg1)
11207 || value_equal (arg2, arg1)));
11208
11209 case OP_ATR_FIRST:
11210 case OP_ATR_LAST:
11211 case OP_ATR_LENGTH:
11212 {
76a01679 11213 struct type *type_arg;
5b4ee69b 11214
76a01679
JB
11215 if (exp->elts[*pos].opcode == OP_TYPE)
11216 {
11217 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11218 arg1 = NULL;
5bc23cb3 11219 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11220 }
11221 else
11222 {
11223 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11224 type_arg = NULL;
11225 }
11226
11227 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11228 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11229 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11230 *pos += 4;
11231
11232 if (noside == EVAL_SKIP)
11233 goto nosideret;
11234
11235 if (type_arg == NULL)
11236 {
11237 arg1 = ada_coerce_ref (arg1);
11238
ad82864c 11239 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11240 arg1 = ada_coerce_to_simple_array (arg1);
11241
aa4fb036 11242 if (op == OP_ATR_LENGTH)
1eea4ebd 11243 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11244 else
11245 {
11246 type = ada_index_type (value_type (arg1), tem,
11247 ada_attribute_name (op));
11248 if (type == NULL)
11249 type = builtin_type (exp->gdbarch)->builtin_int;
11250 }
76a01679
JB
11251
11252 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11253 return allocate_value (type);
76a01679
JB
11254
11255 switch (op)
11256 {
11257 default: /* Should never happen. */
323e0a4a 11258 error (_("unexpected attribute encountered"));
76a01679 11259 case OP_ATR_FIRST:
1eea4ebd
UW
11260 return value_from_longest
11261 (type, ada_array_bound (arg1, tem, 0));
76a01679 11262 case OP_ATR_LAST:
1eea4ebd
UW
11263 return value_from_longest
11264 (type, ada_array_bound (arg1, tem, 1));
76a01679 11265 case OP_ATR_LENGTH:
1eea4ebd
UW
11266 return value_from_longest
11267 (type, ada_array_length (arg1, tem));
76a01679
JB
11268 }
11269 }
11270 else if (discrete_type_p (type_arg))
11271 {
11272 struct type *range_type;
0d5cff50 11273 const char *name = ada_type_name (type_arg);
5b4ee69b 11274
76a01679
JB
11275 range_type = NULL;
11276 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11277 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11278 if (range_type == NULL)
11279 range_type = type_arg;
11280 switch (op)
11281 {
11282 default:
323e0a4a 11283 error (_("unexpected attribute encountered"));
76a01679 11284 case OP_ATR_FIRST:
690cc4eb 11285 return value_from_longest
43bbcdc2 11286 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11287 case OP_ATR_LAST:
690cc4eb 11288 return value_from_longest
43bbcdc2 11289 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11290 case OP_ATR_LENGTH:
323e0a4a 11291 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11292 }
11293 }
11294 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11295 error (_("unimplemented type attribute"));
76a01679
JB
11296 else
11297 {
11298 LONGEST low, high;
11299
ad82864c
JB
11300 if (ada_is_constrained_packed_array_type (type_arg))
11301 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11302
aa4fb036 11303 if (op == OP_ATR_LENGTH)
1eea4ebd 11304 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11305 else
11306 {
11307 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11308 if (type == NULL)
11309 type = builtin_type (exp->gdbarch)->builtin_int;
11310 }
1eea4ebd 11311
76a01679
JB
11312 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11313 return allocate_value (type);
11314
11315 switch (op)
11316 {
11317 default:
323e0a4a 11318 error (_("unexpected attribute encountered"));
76a01679 11319 case OP_ATR_FIRST:
1eea4ebd 11320 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11321 return value_from_longest (type, low);
11322 case OP_ATR_LAST:
1eea4ebd 11323 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11324 return value_from_longest (type, high);
11325 case OP_ATR_LENGTH:
1eea4ebd
UW
11326 low = ada_array_bound_from_type (type_arg, tem, 0);
11327 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11328 return value_from_longest (type, high - low + 1);
11329 }
11330 }
14f9c5c9
AS
11331 }
11332
4c4b4cd2
PH
11333 case OP_ATR_TAG:
11334 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11335 if (noside == EVAL_SKIP)
76a01679 11336 goto nosideret;
4c4b4cd2
PH
11337
11338 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11339 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11340
11341 return ada_value_tag (arg1);
11342
11343 case OP_ATR_MIN:
11344 case OP_ATR_MAX:
11345 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11346 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11347 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11348 if (noside == EVAL_SKIP)
76a01679 11349 goto nosideret;
d2e4a39e 11350 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11351 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11352 else
f44316fa
UW
11353 {
11354 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11355 return value_binop (arg1, arg2,
11356 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11357 }
14f9c5c9 11358
4c4b4cd2
PH
11359 case OP_ATR_MODULUS:
11360 {
31dedfee 11361 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11362
5b4ee69b 11363 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11364 if (noside == EVAL_SKIP)
11365 goto nosideret;
4c4b4cd2 11366
76a01679 11367 if (!ada_is_modular_type (type_arg))
323e0a4a 11368 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11369
76a01679
JB
11370 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11371 ada_modulus (type_arg));
4c4b4cd2
PH
11372 }
11373
11374
11375 case OP_ATR_POS:
11376 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11377 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11378 if (noside == EVAL_SKIP)
76a01679 11379 goto nosideret;
3cb382c9
UW
11380 type = builtin_type (exp->gdbarch)->builtin_int;
11381 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11382 return value_zero (type, not_lval);
14f9c5c9 11383 else
3cb382c9 11384 return value_pos_atr (type, arg1);
14f9c5c9 11385
4c4b4cd2
PH
11386 case OP_ATR_SIZE:
11387 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11388 type = value_type (arg1);
11389
11390 /* If the argument is a reference, then dereference its type, since
11391 the user is really asking for the size of the actual object,
11392 not the size of the pointer. */
11393 if (TYPE_CODE (type) == TYPE_CODE_REF)
11394 type = TYPE_TARGET_TYPE (type);
11395
4c4b4cd2 11396 if (noside == EVAL_SKIP)
76a01679 11397 goto nosideret;
4c4b4cd2 11398 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11399 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11400 else
22601c15 11401 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11402 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11403
11404 case OP_ATR_VAL:
11405 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11406 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11407 type = exp->elts[pc + 2].type;
14f9c5c9 11408 if (noside == EVAL_SKIP)
76a01679 11409 goto nosideret;
4c4b4cd2 11410 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11411 return value_zero (type, not_lval);
4c4b4cd2 11412 else
76a01679 11413 return value_val_atr (type, arg1);
4c4b4cd2
PH
11414
11415 case BINOP_EXP:
11416 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11417 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11418 if (noside == EVAL_SKIP)
11419 goto nosideret;
11420 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11421 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11422 else
f44316fa
UW
11423 {
11424 /* For integer exponentiation operations,
11425 only promote the first argument. */
11426 if (is_integral_type (value_type (arg2)))
11427 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11428 else
11429 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11430
11431 return value_binop (arg1, arg2, op);
11432 }
4c4b4cd2
PH
11433
11434 case UNOP_PLUS:
11435 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11436 if (noside == EVAL_SKIP)
11437 goto nosideret;
11438 else
11439 return arg1;
11440
11441 case UNOP_ABS:
11442 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11443 if (noside == EVAL_SKIP)
11444 goto nosideret;
f44316fa 11445 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11446 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11447 return value_neg (arg1);
14f9c5c9 11448 else
4c4b4cd2 11449 return arg1;
14f9c5c9
AS
11450
11451 case UNOP_IND:
5ec18f2b 11452 preeval_pos = *pos;
6b0d7253 11453 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11454 if (noside == EVAL_SKIP)
4c4b4cd2 11455 goto nosideret;
df407dfe 11456 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11457 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11458 {
11459 if (ada_is_array_descriptor_type (type))
11460 /* GDB allows dereferencing GNAT array descriptors. */
11461 {
11462 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11463
4c4b4cd2 11464 if (arrType == NULL)
323e0a4a 11465 error (_("Attempt to dereference null array pointer."));
00a4c844 11466 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11467 }
11468 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11469 || TYPE_CODE (type) == TYPE_CODE_REF
11470 /* In C you can dereference an array to get the 1st elt. */
11471 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11472 {
5ec18f2b
JG
11473 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11474 only be determined by inspecting the object's tag.
11475 This means that we need to evaluate completely the
11476 expression in order to get its type. */
11477
023db19c
JB
11478 if ((TYPE_CODE (type) == TYPE_CODE_REF
11479 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11480 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11481 {
11482 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11483 EVAL_NORMAL);
11484 type = value_type (ada_value_ind (arg1));
11485 }
11486 else
11487 {
11488 type = to_static_fixed_type
11489 (ada_aligned_type
11490 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11491 }
c1b5a1a6 11492 ada_ensure_varsize_limit (type);
714e53ab
PH
11493 return value_zero (type, lval_memory);
11494 }
4c4b4cd2 11495 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11496 {
11497 /* GDB allows dereferencing an int. */
11498 if (expect_type == NULL)
11499 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11500 lval_memory);
11501 else
11502 {
11503 expect_type =
11504 to_static_fixed_type (ada_aligned_type (expect_type));
11505 return value_zero (expect_type, lval_memory);
11506 }
11507 }
4c4b4cd2 11508 else
323e0a4a 11509 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11510 }
0963b4bd 11511 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11512 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11513
96967637
JB
11514 if (TYPE_CODE (type) == TYPE_CODE_INT)
11515 /* GDB allows dereferencing an int. If we were given
11516 the expect_type, then use that as the target type.
11517 Otherwise, assume that the target type is an int. */
11518 {
11519 if (expect_type != NULL)
11520 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11521 arg1));
11522 else
11523 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11524 (CORE_ADDR) value_as_address (arg1));
11525 }
6b0d7253 11526
4c4b4cd2
PH
11527 if (ada_is_array_descriptor_type (type))
11528 /* GDB allows dereferencing GNAT array descriptors. */
11529 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11530 else
4c4b4cd2 11531 return ada_value_ind (arg1);
14f9c5c9
AS
11532
11533 case STRUCTOP_STRUCT:
11534 tem = longest_to_int (exp->elts[pc + 1].longconst);
11535 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11536 preeval_pos = *pos;
14f9c5c9
AS
11537 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11538 if (noside == EVAL_SKIP)
4c4b4cd2 11539 goto nosideret;
14f9c5c9 11540 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11541 {
df407dfe 11542 struct type *type1 = value_type (arg1);
5b4ee69b 11543
76a01679
JB
11544 if (ada_is_tagged_type (type1, 1))
11545 {
11546 type = ada_lookup_struct_elt_type (type1,
11547 &exp->elts[pc + 2].string,
988f6b3d 11548 1, 1);
5ec18f2b
JG
11549
11550 /* If the field is not found, check if it exists in the
11551 extension of this object's type. This means that we
11552 need to evaluate completely the expression. */
11553
76a01679 11554 if (type == NULL)
5ec18f2b
JG
11555 {
11556 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11557 EVAL_NORMAL);
11558 arg1 = ada_value_struct_elt (arg1,
11559 &exp->elts[pc + 2].string,
11560 0);
11561 arg1 = unwrap_value (arg1);
11562 type = value_type (ada_to_fixed_value (arg1));
11563 }
76a01679
JB
11564 }
11565 else
11566 type =
11567 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11568 0);
76a01679
JB
11569
11570 return value_zero (ada_aligned_type (type), lval_memory);
11571 }
14f9c5c9 11572 else
a579cd9a
MW
11573 {
11574 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11575 arg1 = unwrap_value (arg1);
11576 return ada_to_fixed_value (arg1);
11577 }
284614f0 11578
14f9c5c9 11579 case OP_TYPE:
4c4b4cd2
PH
11580 /* The value is not supposed to be used. This is here to make it
11581 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11582 (*pos) += 2;
11583 if (noside == EVAL_SKIP)
4c4b4cd2 11584 goto nosideret;
14f9c5c9 11585 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11586 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11587 else
323e0a4a 11588 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11589
11590 case OP_AGGREGATE:
11591 case OP_CHOICES:
11592 case OP_OTHERS:
11593 case OP_DISCRETE_RANGE:
11594 case OP_POSITIONAL:
11595 case OP_NAME:
11596 if (noside == EVAL_NORMAL)
11597 switch (op)
11598 {
11599 case OP_NAME:
11600 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11601 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11602 case OP_AGGREGATE:
11603 error (_("Aggregates only allowed on the right of an assignment"));
11604 default:
0963b4bd
MS
11605 internal_error (__FILE__, __LINE__,
11606 _("aggregate apparently mangled"));
52ce6436
PH
11607 }
11608
11609 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11610 *pos += oplen - 1;
11611 for (tem = 0; tem < nargs; tem += 1)
11612 ada_evaluate_subexp (NULL, exp, pos, noside);
11613 goto nosideret;
14f9c5c9
AS
11614 }
11615
11616nosideret:
ced9779b 11617 return eval_skip_value (exp);
14f9c5c9 11618}
14f9c5c9 11619\f
d2e4a39e 11620
4c4b4cd2 11621 /* Fixed point */
14f9c5c9
AS
11622
11623/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11624 type name that encodes the 'small and 'delta information.
4c4b4cd2 11625 Otherwise, return NULL. */
14f9c5c9 11626
d2e4a39e 11627static const char *
ebf56fd3 11628fixed_type_info (struct type *type)
14f9c5c9 11629{
d2e4a39e 11630 const char *name = ada_type_name (type);
14f9c5c9
AS
11631 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11632
d2e4a39e
AS
11633 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11634 {
14f9c5c9 11635 const char *tail = strstr (name, "___XF_");
5b4ee69b 11636
14f9c5c9 11637 if (tail == NULL)
4c4b4cd2 11638 return NULL;
d2e4a39e 11639 else
4c4b4cd2 11640 return tail + 5;
14f9c5c9
AS
11641 }
11642 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11643 return fixed_type_info (TYPE_TARGET_TYPE (type));
11644 else
11645 return NULL;
11646}
11647
4c4b4cd2 11648/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11649
11650int
ebf56fd3 11651ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11652{
11653 return fixed_type_info (type) != NULL;
11654}
11655
4c4b4cd2
PH
11656/* Return non-zero iff TYPE represents a System.Address type. */
11657
11658int
11659ada_is_system_address_type (struct type *type)
11660{
11661 return (TYPE_NAME (type)
11662 && strcmp (TYPE_NAME (type), "system__address") == 0);
11663}
11664
14f9c5c9 11665/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11666 type, return the target floating-point type to be used to represent
11667 of this type during internal computation. */
11668
11669static struct type *
11670ada_scaling_type (struct type *type)
11671{
11672 return builtin_type (get_type_arch (type))->builtin_long_double;
11673}
11674
11675/* Assuming that TYPE is the representation of an Ada fixed-point
11676 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11677 delta cannot be determined. */
14f9c5c9 11678
50eff16b 11679struct value *
ebf56fd3 11680ada_delta (struct type *type)
14f9c5c9
AS
11681{
11682 const char *encoding = fixed_type_info (type);
50eff16b
UW
11683 struct type *scale_type = ada_scaling_type (type);
11684
11685 long long num, den;
11686
11687 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11688 return nullptr;
d2e4a39e 11689 else
50eff16b
UW
11690 return value_binop (value_from_longest (scale_type, num),
11691 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11692}
11693
11694/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11695 factor ('SMALL value) associated with the type. */
14f9c5c9 11696
50eff16b
UW
11697struct value *
11698ada_scaling_factor (struct type *type)
14f9c5c9
AS
11699{
11700 const char *encoding = fixed_type_info (type);
50eff16b
UW
11701 struct type *scale_type = ada_scaling_type (type);
11702
11703 long long num0, den0, num1, den1;
14f9c5c9 11704 int n;
d2e4a39e 11705
50eff16b 11706 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11707 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11708
11709 if (n < 2)
50eff16b 11710 return value_from_longest (scale_type, 1);
14f9c5c9 11711 else if (n == 4)
50eff16b
UW
11712 return value_binop (value_from_longest (scale_type, num1),
11713 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11714 else
50eff16b
UW
11715 return value_binop (value_from_longest (scale_type, num0),
11716 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11717}
11718
14f9c5c9 11719\f
d2e4a39e 11720
4c4b4cd2 11721 /* Range types */
14f9c5c9
AS
11722
11723/* Scan STR beginning at position K for a discriminant name, and
11724 return the value of that discriminant field of DVAL in *PX. If
11725 PNEW_K is not null, put the position of the character beyond the
11726 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11727 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11728
11729static int
108d56a4 11730scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11731 int *pnew_k)
14f9c5c9
AS
11732{
11733 static char *bound_buffer = NULL;
11734 static size_t bound_buffer_len = 0;
5da1a4d3 11735 const char *pstart, *pend, *bound;
d2e4a39e 11736 struct value *bound_val;
14f9c5c9
AS
11737
11738 if (dval == NULL || str == NULL || str[k] == '\0')
11739 return 0;
11740
5da1a4d3
SM
11741 pstart = str + k;
11742 pend = strstr (pstart, "__");
14f9c5c9
AS
11743 if (pend == NULL)
11744 {
5da1a4d3 11745 bound = pstart;
14f9c5c9
AS
11746 k += strlen (bound);
11747 }
d2e4a39e 11748 else
14f9c5c9 11749 {
5da1a4d3
SM
11750 int len = pend - pstart;
11751
11752 /* Strip __ and beyond. */
11753 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11754 strncpy (bound_buffer, pstart, len);
11755 bound_buffer[len] = '\0';
11756
14f9c5c9 11757 bound = bound_buffer;
d2e4a39e 11758 k = pend - str;
14f9c5c9 11759 }
d2e4a39e 11760
df407dfe 11761 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11762 if (bound_val == NULL)
11763 return 0;
11764
11765 *px = value_as_long (bound_val);
11766 if (pnew_k != NULL)
11767 *pnew_k = k;
11768 return 1;
11769}
11770
11771/* Value of variable named NAME in the current environment. If
11772 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11773 otherwise causes an error with message ERR_MSG. */
11774
d2e4a39e 11775static struct value *
edb0c9cb 11776get_var_value (const char *name, const char *err_msg)
14f9c5c9 11777{
b5ec771e 11778 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11779
b5ec771e
PA
11780 struct block_symbol *syms;
11781 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11782 get_selected_block (0),
11783 VAR_DOMAIN, &syms, 1);
ec6a20c2 11784 struct cleanup *old_chain = make_cleanup (xfree, syms);
14f9c5c9
AS
11785
11786 if (nsyms != 1)
11787 {
ec6a20c2 11788 do_cleanups (old_chain);
14f9c5c9 11789 if (err_msg == NULL)
4c4b4cd2 11790 return 0;
14f9c5c9 11791 else
8a3fe4f8 11792 error (("%s"), err_msg);
14f9c5c9
AS
11793 }
11794
ec6a20c2
JB
11795 struct value *result = value_of_variable (syms[0].symbol, syms[0].block);
11796 do_cleanups (old_chain);
11797 return result;
14f9c5c9 11798}
d2e4a39e 11799
edb0c9cb
PA
11800/* Value of integer variable named NAME in the current environment.
11801 If no such variable is found, returns false. Otherwise, sets VALUE
11802 to the variable's value and returns true. */
4c4b4cd2 11803
edb0c9cb
PA
11804bool
11805get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11806{
4c4b4cd2 11807 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11808
14f9c5c9 11809 if (var_val == 0)
edb0c9cb
PA
11810 return false;
11811
11812 value = value_as_long (var_val);
11813 return true;
14f9c5c9 11814}
d2e4a39e 11815
14f9c5c9
AS
11816
11817/* Return a range type whose base type is that of the range type named
11818 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11819 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11820 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11821 corresponding range type from debug information; fall back to using it
11822 if symbol lookup fails. If a new type must be created, allocate it
11823 like ORIG_TYPE was. The bounds information, in general, is encoded
11824 in NAME, the base type given in the named range type. */
14f9c5c9 11825
d2e4a39e 11826static struct type *
28c85d6c 11827to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11828{
0d5cff50 11829 const char *name;
14f9c5c9 11830 struct type *base_type;
108d56a4 11831 const char *subtype_info;
14f9c5c9 11832
28c85d6c
JB
11833 gdb_assert (raw_type != NULL);
11834 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11835
1ce677a4 11836 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11837 base_type = TYPE_TARGET_TYPE (raw_type);
11838 else
11839 base_type = raw_type;
11840
28c85d6c 11841 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11842 subtype_info = strstr (name, "___XD");
11843 if (subtype_info == NULL)
690cc4eb 11844 {
43bbcdc2
PH
11845 LONGEST L = ada_discrete_type_low_bound (raw_type);
11846 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11847
690cc4eb
PH
11848 if (L < INT_MIN || U > INT_MAX)
11849 return raw_type;
11850 else
0c9c3474
SA
11851 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11852 L, U);
690cc4eb 11853 }
14f9c5c9
AS
11854 else
11855 {
11856 static char *name_buf = NULL;
11857 static size_t name_len = 0;
11858 int prefix_len = subtype_info - name;
11859 LONGEST L, U;
11860 struct type *type;
108d56a4 11861 const char *bounds_str;
14f9c5c9
AS
11862 int n;
11863
11864 GROW_VECT (name_buf, name_len, prefix_len + 5);
11865 strncpy (name_buf, name, prefix_len);
11866 name_buf[prefix_len] = '\0';
11867
11868 subtype_info += 5;
11869 bounds_str = strchr (subtype_info, '_');
11870 n = 1;
11871
d2e4a39e 11872 if (*subtype_info == 'L')
4c4b4cd2
PH
11873 {
11874 if (!ada_scan_number (bounds_str, n, &L, &n)
11875 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11876 return raw_type;
11877 if (bounds_str[n] == '_')
11878 n += 2;
0963b4bd 11879 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11880 n += 1;
11881 subtype_info += 1;
11882 }
d2e4a39e 11883 else
4c4b4cd2 11884 {
4c4b4cd2 11885 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11886 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11887 {
323e0a4a 11888 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11889 L = 1;
11890 }
11891 }
14f9c5c9 11892
d2e4a39e 11893 if (*subtype_info == 'U')
4c4b4cd2
PH
11894 {
11895 if (!ada_scan_number (bounds_str, n, &U, &n)
11896 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11897 return raw_type;
11898 }
d2e4a39e 11899 else
4c4b4cd2 11900 {
4c4b4cd2 11901 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11902 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11903 {
323e0a4a 11904 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11905 U = L;
11906 }
11907 }
14f9c5c9 11908
0c9c3474
SA
11909 type = create_static_range_type (alloc_type_copy (raw_type),
11910 base_type, L, U);
f5a91472
JB
11911 /* create_static_range_type alters the resulting type's length
11912 to match the size of the base_type, which is not what we want.
11913 Set it back to the original range type's length. */
11914 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11915 TYPE_NAME (type) = name;
14f9c5c9
AS
11916 return type;
11917 }
11918}
11919
4c4b4cd2
PH
11920/* True iff NAME is the name of a range type. */
11921
14f9c5c9 11922int
d2e4a39e 11923ada_is_range_type_name (const char *name)
14f9c5c9
AS
11924{
11925 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11926}
14f9c5c9 11927\f
d2e4a39e 11928
4c4b4cd2
PH
11929 /* Modular types */
11930
11931/* True iff TYPE is an Ada modular type. */
14f9c5c9 11932
14f9c5c9 11933int
d2e4a39e 11934ada_is_modular_type (struct type *type)
14f9c5c9 11935{
18af8284 11936 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11937
11938 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11939 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11940 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11941}
11942
4c4b4cd2
PH
11943/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11944
61ee279c 11945ULONGEST
0056e4d5 11946ada_modulus (struct type *type)
14f9c5c9 11947{
43bbcdc2 11948 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11949}
d2e4a39e 11950\f
f7f9143b
JB
11951
11952/* Ada exception catchpoint support:
11953 ---------------------------------
11954
11955 We support 3 kinds of exception catchpoints:
11956 . catchpoints on Ada exceptions
11957 . catchpoints on unhandled Ada exceptions
11958 . catchpoints on failed assertions
11959
11960 Exceptions raised during failed assertions, or unhandled exceptions
11961 could perfectly be caught with the general catchpoint on Ada exceptions.
11962 However, we can easily differentiate these two special cases, and having
11963 the option to distinguish these two cases from the rest can be useful
11964 to zero-in on certain situations.
11965
11966 Exception catchpoints are a specialized form of breakpoint,
11967 since they rely on inserting breakpoints inside known routines
11968 of the GNAT runtime. The implementation therefore uses a standard
11969 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11970 of breakpoint_ops.
11971
0259addd
JB
11972 Support in the runtime for exception catchpoints have been changed
11973 a few times already, and these changes affect the implementation
11974 of these catchpoints. In order to be able to support several
11975 variants of the runtime, we use a sniffer that will determine
28010a5d 11976 the runtime variant used by the program being debugged. */
f7f9143b 11977
82eacd52
JB
11978/* Ada's standard exceptions.
11979
11980 The Ada 83 standard also defined Numeric_Error. But there so many
11981 situations where it was unclear from the Ada 83 Reference Manual
11982 (RM) whether Constraint_Error or Numeric_Error should be raised,
11983 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11984 Interpretation saying that anytime the RM says that Numeric_Error
11985 should be raised, the implementation may raise Constraint_Error.
11986 Ada 95 went one step further and pretty much removed Numeric_Error
11987 from the list of standard exceptions (it made it a renaming of
11988 Constraint_Error, to help preserve compatibility when compiling
11989 an Ada83 compiler). As such, we do not include Numeric_Error from
11990 this list of standard exceptions. */
3d0b0fa3 11991
a121b7c1 11992static const char *standard_exc[] = {
3d0b0fa3
JB
11993 "constraint_error",
11994 "program_error",
11995 "storage_error",
11996 "tasking_error"
11997};
11998
0259addd
JB
11999typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
12000
12001/* A structure that describes how to support exception catchpoints
12002 for a given executable. */
12003
12004struct exception_support_info
12005{
12006 /* The name of the symbol to break on in order to insert
12007 a catchpoint on exceptions. */
12008 const char *catch_exception_sym;
12009
12010 /* The name of the symbol to break on in order to insert
12011 a catchpoint on unhandled exceptions. */
12012 const char *catch_exception_unhandled_sym;
12013
12014 /* The name of the symbol to break on in order to insert
12015 a catchpoint on failed assertions. */
12016 const char *catch_assert_sym;
12017
9f757bf7
XR
12018 /* The name of the symbol to break on in order to insert
12019 a catchpoint on exception handling. */
12020 const char *catch_handlers_sym;
12021
0259addd
JB
12022 /* Assuming that the inferior just triggered an unhandled exception
12023 catchpoint, this function is responsible for returning the address
12024 in inferior memory where the name of that exception is stored.
12025 Return zero if the address could not be computed. */
12026 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
12027};
12028
12029static CORE_ADDR ada_unhandled_exception_name_addr (void);
12030static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
12031
12032/* The following exception support info structure describes how to
12033 implement exception catchpoints with the latest version of the
12034 Ada runtime (as of 2007-03-06). */
12035
12036static const struct exception_support_info default_exception_support_info =
12037{
12038 "__gnat_debug_raise_exception", /* catch_exception_sym */
12039 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12040 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 12041 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12042 ada_unhandled_exception_name_addr
12043};
12044
12045/* The following exception support info structure describes how to
12046 implement exception catchpoints with a slightly older version
12047 of the Ada runtime. */
12048
12049static const struct exception_support_info exception_support_info_fallback =
12050{
12051 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12052 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12053 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 12054 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12055 ada_unhandled_exception_name_addr_from_raise
12056};
12057
f17011e0
JB
12058/* Return nonzero if we can detect the exception support routines
12059 described in EINFO.
12060
12061 This function errors out if an abnormal situation is detected
12062 (for instance, if we find the exception support routines, but
12063 that support is found to be incomplete). */
12064
12065static int
12066ada_has_this_exception_support (const struct exception_support_info *einfo)
12067{
12068 struct symbol *sym;
12069
12070 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12071 that should be compiled with debugging information. As a result, we
12072 expect to find that symbol in the symtabs. */
12073
12074 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12075 if (sym == NULL)
a6af7abe
JB
12076 {
12077 /* Perhaps we did not find our symbol because the Ada runtime was
12078 compiled without debugging info, or simply stripped of it.
12079 It happens on some GNU/Linux distributions for instance, where
12080 users have to install a separate debug package in order to get
12081 the runtime's debugging info. In that situation, let the user
12082 know why we cannot insert an Ada exception catchpoint.
12083
12084 Note: Just for the purpose of inserting our Ada exception
12085 catchpoint, we could rely purely on the associated minimal symbol.
12086 But we would be operating in degraded mode anyway, since we are
12087 still lacking the debugging info needed later on to extract
12088 the name of the exception being raised (this name is printed in
12089 the catchpoint message, and is also used when trying to catch
12090 a specific exception). We do not handle this case for now. */
3b7344d5 12091 struct bound_minimal_symbol msym
1c8e84b0
JB
12092 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12093
3b7344d5 12094 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
12095 error (_("Your Ada runtime appears to be missing some debugging "
12096 "information.\nCannot insert Ada exception catchpoint "
12097 "in this configuration."));
12098
12099 return 0;
12100 }
f17011e0
JB
12101
12102 /* Make sure that the symbol we found corresponds to a function. */
12103
12104 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12105 error (_("Symbol \"%s\" is not a function (class = %d)"),
12106 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12107
12108 return 1;
12109}
12110
0259addd
JB
12111/* Inspect the Ada runtime and determine which exception info structure
12112 should be used to provide support for exception catchpoints.
12113
3eecfa55
JB
12114 This function will always set the per-inferior exception_info,
12115 or raise an error. */
0259addd
JB
12116
12117static void
12118ada_exception_support_info_sniffer (void)
12119{
3eecfa55 12120 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
12121
12122 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 12123 if (data->exception_info != NULL)
0259addd
JB
12124 return;
12125
12126 /* Check the latest (default) exception support info. */
f17011e0 12127 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 12128 {
3eecfa55 12129 data->exception_info = &default_exception_support_info;
0259addd
JB
12130 return;
12131 }
12132
12133 /* Try our fallback exception suport info. */
f17011e0 12134 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 12135 {
3eecfa55 12136 data->exception_info = &exception_support_info_fallback;
0259addd
JB
12137 return;
12138 }
12139
12140 /* Sometimes, it is normal for us to not be able to find the routine
12141 we are looking for. This happens when the program is linked with
12142 the shared version of the GNAT runtime, and the program has not been
12143 started yet. Inform the user of these two possible causes if
12144 applicable. */
12145
ccefe4c4 12146 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
12147 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12148
12149 /* If the symbol does not exist, then check that the program is
12150 already started, to make sure that shared libraries have been
12151 loaded. If it is not started, this may mean that the symbol is
12152 in a shared library. */
12153
12154 if (ptid_get_pid (inferior_ptid) == 0)
12155 error (_("Unable to insert catchpoint. Try to start the program first."));
12156
12157 /* At this point, we know that we are debugging an Ada program and
12158 that the inferior has been started, but we still are not able to
0963b4bd 12159 find the run-time symbols. That can mean that we are in
0259addd
JB
12160 configurable run time mode, or that a-except as been optimized
12161 out by the linker... In any case, at this point it is not worth
12162 supporting this feature. */
12163
7dda8cff 12164 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12165}
12166
f7f9143b
JB
12167/* True iff FRAME is very likely to be that of a function that is
12168 part of the runtime system. This is all very heuristic, but is
12169 intended to be used as advice as to what frames are uninteresting
12170 to most users. */
12171
12172static int
12173is_known_support_routine (struct frame_info *frame)
12174{
692465f1 12175 enum language func_lang;
f7f9143b 12176 int i;
f35a17b5 12177 const char *fullname;
f7f9143b 12178
4ed6b5be
JB
12179 /* If this code does not have any debugging information (no symtab),
12180 This cannot be any user code. */
f7f9143b 12181
51abb421 12182 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12183 if (sal.symtab == NULL)
12184 return 1;
12185
4ed6b5be
JB
12186 /* If there is a symtab, but the associated source file cannot be
12187 located, then assume this is not user code: Selecting a frame
12188 for which we cannot display the code would not be very helpful
12189 for the user. This should also take care of case such as VxWorks
12190 where the kernel has some debugging info provided for a few units. */
f7f9143b 12191
f35a17b5
JK
12192 fullname = symtab_to_fullname (sal.symtab);
12193 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12194 return 1;
12195
4ed6b5be
JB
12196 /* Check the unit filename againt the Ada runtime file naming.
12197 We also check the name of the objfile against the name of some
12198 known system libraries that sometimes come with debugging info
12199 too. */
12200
f7f9143b
JB
12201 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12202 {
12203 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12204 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12205 return 1;
eb822aa6
DE
12206 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12207 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12208 return 1;
f7f9143b
JB
12209 }
12210
4ed6b5be 12211 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12212
c6dc63a1
TT
12213 gdb::unique_xmalloc_ptr<char> func_name
12214 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12215 if (func_name == NULL)
12216 return 1;
12217
12218 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12219 {
12220 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12221 if (re_exec (func_name.get ()))
12222 return 1;
f7f9143b
JB
12223 }
12224
12225 return 0;
12226}
12227
12228/* Find the first frame that contains debugging information and that is not
12229 part of the Ada run-time, starting from FI and moving upward. */
12230
0ef643c8 12231void
f7f9143b
JB
12232ada_find_printable_frame (struct frame_info *fi)
12233{
12234 for (; fi != NULL; fi = get_prev_frame (fi))
12235 {
12236 if (!is_known_support_routine (fi))
12237 {
12238 select_frame (fi);
12239 break;
12240 }
12241 }
12242
12243}
12244
12245/* Assuming that the inferior just triggered an unhandled exception
12246 catchpoint, return the address in inferior memory where the name
12247 of the exception is stored.
12248
12249 Return zero if the address could not be computed. */
12250
12251static CORE_ADDR
12252ada_unhandled_exception_name_addr (void)
0259addd
JB
12253{
12254 return parse_and_eval_address ("e.full_name");
12255}
12256
12257/* Same as ada_unhandled_exception_name_addr, except that this function
12258 should be used when the inferior uses an older version of the runtime,
12259 where the exception name needs to be extracted from a specific frame
12260 several frames up in the callstack. */
12261
12262static CORE_ADDR
12263ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12264{
12265 int frame_level;
12266 struct frame_info *fi;
3eecfa55 12267 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12268
12269 /* To determine the name of this exception, we need to select
12270 the frame corresponding to RAISE_SYM_NAME. This frame is
12271 at least 3 levels up, so we simply skip the first 3 frames
12272 without checking the name of their associated function. */
12273 fi = get_current_frame ();
12274 for (frame_level = 0; frame_level < 3; frame_level += 1)
12275 if (fi != NULL)
12276 fi = get_prev_frame (fi);
12277
12278 while (fi != NULL)
12279 {
692465f1
JB
12280 enum language func_lang;
12281
c6dc63a1
TT
12282 gdb::unique_xmalloc_ptr<char> func_name
12283 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12284 if (func_name != NULL)
12285 {
c6dc63a1 12286 if (strcmp (func_name.get (),
55b87a52
KS
12287 data->exception_info->catch_exception_sym) == 0)
12288 break; /* We found the frame we were looking for... */
12289 fi = get_prev_frame (fi);
12290 }
f7f9143b
JB
12291 }
12292
12293 if (fi == NULL)
12294 return 0;
12295
12296 select_frame (fi);
12297 return parse_and_eval_address ("id.full_name");
12298}
12299
12300/* Assuming the inferior just triggered an Ada exception catchpoint
12301 (of any type), return the address in inferior memory where the name
12302 of the exception is stored, if applicable.
12303
45db7c09
PA
12304 Assumes the selected frame is the current frame.
12305
f7f9143b
JB
12306 Return zero if the address could not be computed, or if not relevant. */
12307
12308static CORE_ADDR
761269c8 12309ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12310 struct breakpoint *b)
12311{
3eecfa55
JB
12312 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12313
f7f9143b
JB
12314 switch (ex)
12315 {
761269c8 12316 case ada_catch_exception:
f7f9143b
JB
12317 return (parse_and_eval_address ("e.full_name"));
12318 break;
12319
761269c8 12320 case ada_catch_exception_unhandled:
3eecfa55 12321 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12322 break;
9f757bf7
XR
12323
12324 case ada_catch_handlers:
12325 return 0; /* The runtimes does not provide access to the exception
12326 name. */
12327 break;
12328
761269c8 12329 case ada_catch_assert:
f7f9143b
JB
12330 return 0; /* Exception name is not relevant in this case. */
12331 break;
12332
12333 default:
12334 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12335 break;
12336 }
12337
12338 return 0; /* Should never be reached. */
12339}
12340
e547c119
JB
12341/* Assuming the inferior is stopped at an exception catchpoint,
12342 return the message which was associated to the exception, if
12343 available. Return NULL if the message could not be retrieved.
12344
12345 The caller must xfree the string after use.
12346
12347 Note: The exception message can be associated to an exception
12348 either through the use of the Raise_Exception function, or
12349 more simply (Ada 2005 and later), via:
12350
12351 raise Exception_Name with "exception message";
12352
12353 */
12354
12355static char *
12356ada_exception_message_1 (void)
12357{
12358 struct value *e_msg_val;
12359 char *e_msg = NULL;
12360 int e_msg_len;
12361 struct cleanup *cleanups;
12362
12363 /* For runtimes that support this feature, the exception message
12364 is passed as an unbounded string argument called "message". */
12365 e_msg_val = parse_and_eval ("message");
12366 if (e_msg_val == NULL)
12367 return NULL; /* Exception message not supported. */
12368
12369 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12370 gdb_assert (e_msg_val != NULL);
12371 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12372
12373 /* If the message string is empty, then treat it as if there was
12374 no exception message. */
12375 if (e_msg_len <= 0)
12376 return NULL;
12377
12378 e_msg = (char *) xmalloc (e_msg_len + 1);
12379 cleanups = make_cleanup (xfree, e_msg);
12380 read_memory_string (value_address (e_msg_val), e_msg, e_msg_len + 1);
12381 e_msg[e_msg_len] = '\0';
12382
12383 discard_cleanups (cleanups);
12384 return e_msg;
12385}
12386
12387/* Same as ada_exception_message_1, except that all exceptions are
12388 contained here (returning NULL instead). */
12389
12390static char *
12391ada_exception_message (void)
12392{
12393 char *e_msg = NULL; /* Avoid a spurious uninitialized warning. */
12394
12395 TRY
12396 {
12397 e_msg = ada_exception_message_1 ();
12398 }
12399 CATCH (e, RETURN_MASK_ERROR)
12400 {
12401 e_msg = NULL;
12402 }
12403 END_CATCH
12404
12405 return e_msg;
12406}
12407
f7f9143b
JB
12408/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12409 any error that ada_exception_name_addr_1 might cause to be thrown.
12410 When an error is intercepted, a warning with the error message is printed,
12411 and zero is returned. */
12412
12413static CORE_ADDR
761269c8 12414ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12415 struct breakpoint *b)
12416{
f7f9143b
JB
12417 CORE_ADDR result = 0;
12418
492d29ea 12419 TRY
f7f9143b
JB
12420 {
12421 result = ada_exception_name_addr_1 (ex, b);
12422 }
12423
492d29ea 12424 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12425 {
12426 warning (_("failed to get exception name: %s"), e.message);
12427 return 0;
12428 }
492d29ea 12429 END_CATCH
f7f9143b
JB
12430
12431 return result;
12432}
12433
cb7de75e 12434static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12435 (const char *excep_string,
12436 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12437
12438/* Ada catchpoints.
12439
12440 In the case of catchpoints on Ada exceptions, the catchpoint will
12441 stop the target on every exception the program throws. When a user
12442 specifies the name of a specific exception, we translate this
12443 request into a condition expression (in text form), and then parse
12444 it into an expression stored in each of the catchpoint's locations.
12445 We then use this condition to check whether the exception that was
12446 raised is the one the user is interested in. If not, then the
12447 target is resumed again. We store the name of the requested
12448 exception, in order to be able to re-set the condition expression
12449 when symbols change. */
12450
12451/* An instance of this type is used to represent an Ada catchpoint
5625a286 12452 breakpoint location. */
28010a5d 12453
5625a286 12454class ada_catchpoint_location : public bp_location
28010a5d 12455{
5625a286
PA
12456public:
12457 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12458 : bp_location (ops, owner)
12459 {}
28010a5d
PA
12460
12461 /* The condition that checks whether the exception that was raised
12462 is the specific exception the user specified on catchpoint
12463 creation. */
4d01a485 12464 expression_up excep_cond_expr;
28010a5d
PA
12465};
12466
12467/* Implement the DTOR method in the bp_location_ops structure for all
12468 Ada exception catchpoint kinds. */
12469
12470static void
12471ada_catchpoint_location_dtor (struct bp_location *bl)
12472{
12473 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12474
4d01a485 12475 al->excep_cond_expr.reset ();
28010a5d
PA
12476}
12477
12478/* The vtable to be used in Ada catchpoint locations. */
12479
12480static const struct bp_location_ops ada_catchpoint_location_ops =
12481{
12482 ada_catchpoint_location_dtor
12483};
12484
c1fc2657 12485/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12486
c1fc2657 12487struct ada_catchpoint : public breakpoint
28010a5d 12488{
c1fc2657 12489 ~ada_catchpoint () override;
28010a5d
PA
12490
12491 /* The name of the specific exception the user specified. */
12492 char *excep_string;
12493};
12494
12495/* Parse the exception condition string in the context of each of the
12496 catchpoint's locations, and store them for later evaluation. */
12497
12498static void
9f757bf7
XR
12499create_excep_cond_exprs (struct ada_catchpoint *c,
12500 enum ada_exception_catchpoint_kind ex)
28010a5d 12501{
28010a5d 12502 struct bp_location *bl;
28010a5d
PA
12503
12504 /* Nothing to do if there's no specific exception to catch. */
12505 if (c->excep_string == NULL)
12506 return;
12507
12508 /* Same if there are no locations... */
c1fc2657 12509 if (c->loc == NULL)
28010a5d
PA
12510 return;
12511
12512 /* Compute the condition expression in text form, from the specific
12513 expection we want to catch. */
cb7de75e
TT
12514 std::string cond_string
12515 = ada_exception_catchpoint_cond_string (c->excep_string, ex);
28010a5d
PA
12516
12517 /* Iterate over all the catchpoint's locations, and parse an
12518 expression for each. */
c1fc2657 12519 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12520 {
12521 struct ada_catchpoint_location *ada_loc
12522 = (struct ada_catchpoint_location *) bl;
4d01a485 12523 expression_up exp;
28010a5d
PA
12524
12525 if (!bl->shlib_disabled)
12526 {
bbc13ae3 12527 const char *s;
28010a5d 12528
cb7de75e 12529 s = cond_string.c_str ();
492d29ea 12530 TRY
28010a5d 12531 {
036e657b
JB
12532 exp = parse_exp_1 (&s, bl->address,
12533 block_for_pc (bl->address),
12534 0);
28010a5d 12535 }
492d29ea 12536 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12537 {
12538 warning (_("failed to reevaluate internal exception condition "
12539 "for catchpoint %d: %s"),
c1fc2657 12540 c->number, e.message);
849f2b52 12541 }
492d29ea 12542 END_CATCH
28010a5d
PA
12543 }
12544
b22e99fd 12545 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12546 }
28010a5d
PA
12547}
12548
c1fc2657 12549/* ada_catchpoint destructor. */
28010a5d 12550
c1fc2657 12551ada_catchpoint::~ada_catchpoint ()
28010a5d 12552{
c1fc2657 12553 xfree (this->excep_string);
28010a5d
PA
12554}
12555
12556/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12557 structure for all exception catchpoint kinds. */
12558
12559static struct bp_location *
761269c8 12560allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12561 struct breakpoint *self)
12562{
5625a286 12563 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12564}
12565
12566/* Implement the RE_SET method in the breakpoint_ops structure for all
12567 exception catchpoint kinds. */
12568
12569static void
761269c8 12570re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12571{
12572 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12573
12574 /* Call the base class's method. This updates the catchpoint's
12575 locations. */
2060206e 12576 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12577
12578 /* Reparse the exception conditional expressions. One for each
12579 location. */
9f757bf7 12580 create_excep_cond_exprs (c, ex);
28010a5d
PA
12581}
12582
12583/* Returns true if we should stop for this breakpoint hit. If the
12584 user specified a specific exception, we only want to cause a stop
12585 if the program thrown that exception. */
12586
12587static int
12588should_stop_exception (const struct bp_location *bl)
12589{
12590 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12591 const struct ada_catchpoint_location *ada_loc
12592 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12593 int stop;
12594
12595 /* With no specific exception, should always stop. */
12596 if (c->excep_string == NULL)
12597 return 1;
12598
12599 if (ada_loc->excep_cond_expr == NULL)
12600 {
12601 /* We will have a NULL expression if back when we were creating
12602 the expressions, this location's had failed to parse. */
12603 return 1;
12604 }
12605
12606 stop = 1;
492d29ea 12607 TRY
28010a5d
PA
12608 {
12609 struct value *mark;
12610
12611 mark = value_mark ();
4d01a485 12612 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12613 value_free_to_mark (mark);
12614 }
492d29ea
PA
12615 CATCH (ex, RETURN_MASK_ALL)
12616 {
12617 exception_fprintf (gdb_stderr, ex,
12618 _("Error in testing exception condition:\n"));
12619 }
12620 END_CATCH
12621
28010a5d
PA
12622 return stop;
12623}
12624
12625/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12626 for all exception catchpoint kinds. */
12627
12628static void
761269c8 12629check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12630{
12631 bs->stop = should_stop_exception (bs->bp_location_at);
12632}
12633
f7f9143b
JB
12634/* Implement the PRINT_IT method in the breakpoint_ops structure
12635 for all exception catchpoint kinds. */
12636
12637static enum print_stop_action
761269c8 12638print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12639{
79a45e25 12640 struct ui_out *uiout = current_uiout;
348d480f 12641 struct breakpoint *b = bs->breakpoint_at;
e547c119 12642 char *exception_message;
348d480f 12643
956a9fb9 12644 annotate_catchpoint (b->number);
f7f9143b 12645
112e8700 12646 if (uiout->is_mi_like_p ())
f7f9143b 12647 {
112e8700 12648 uiout->field_string ("reason",
956a9fb9 12649 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12650 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12651 }
12652
112e8700
SM
12653 uiout->text (b->disposition == disp_del
12654 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12655 uiout->field_int ("bkptno", b->number);
12656 uiout->text (", ");
f7f9143b 12657
45db7c09
PA
12658 /* ada_exception_name_addr relies on the selected frame being the
12659 current frame. Need to do this here because this function may be
12660 called more than once when printing a stop, and below, we'll
12661 select the first frame past the Ada run-time (see
12662 ada_find_printable_frame). */
12663 select_frame (get_current_frame ());
12664
f7f9143b
JB
12665 switch (ex)
12666 {
761269c8
JB
12667 case ada_catch_exception:
12668 case ada_catch_exception_unhandled:
9f757bf7 12669 case ada_catch_handlers:
956a9fb9
JB
12670 {
12671 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12672 char exception_name[256];
12673
12674 if (addr != 0)
12675 {
c714b426
PA
12676 read_memory (addr, (gdb_byte *) exception_name,
12677 sizeof (exception_name) - 1);
956a9fb9
JB
12678 exception_name [sizeof (exception_name) - 1] = '\0';
12679 }
12680 else
12681 {
12682 /* For some reason, we were unable to read the exception
12683 name. This could happen if the Runtime was compiled
12684 without debugging info, for instance. In that case,
12685 just replace the exception name by the generic string
12686 "exception" - it will read as "an exception" in the
12687 notification we are about to print. */
967cff16 12688 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12689 }
12690 /* In the case of unhandled exception breakpoints, we print
12691 the exception name as "unhandled EXCEPTION_NAME", to make
12692 it clearer to the user which kind of catchpoint just got
12693 hit. We used ui_out_text to make sure that this extra
12694 info does not pollute the exception name in the MI case. */
761269c8 12695 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12696 uiout->text ("unhandled ");
12697 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12698 }
12699 break;
761269c8 12700 case ada_catch_assert:
956a9fb9
JB
12701 /* In this case, the name of the exception is not really
12702 important. Just print "failed assertion" to make it clearer
12703 that his program just hit an assertion-failure catchpoint.
12704 We used ui_out_text because this info does not belong in
12705 the MI output. */
112e8700 12706 uiout->text ("failed assertion");
956a9fb9 12707 break;
f7f9143b 12708 }
e547c119
JB
12709
12710 exception_message = ada_exception_message ();
12711 if (exception_message != NULL)
12712 {
12713 struct cleanup *cleanups = make_cleanup (xfree, exception_message);
12714
12715 uiout->text (" (");
12716 uiout->field_string ("exception-message", exception_message);
12717 uiout->text (")");
12718
12719 do_cleanups (cleanups);
12720 }
12721
112e8700 12722 uiout->text (" at ");
956a9fb9 12723 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12724
12725 return PRINT_SRC_AND_LOC;
12726}
12727
12728/* Implement the PRINT_ONE method in the breakpoint_ops structure
12729 for all exception catchpoint kinds. */
12730
12731static void
761269c8 12732print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12733 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12734{
79a45e25 12735 struct ui_out *uiout = current_uiout;
28010a5d 12736 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12737 struct value_print_options opts;
12738
12739 get_user_print_options (&opts);
12740 if (opts.addressprint)
f7f9143b
JB
12741 {
12742 annotate_field (4);
112e8700 12743 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12744 }
12745
12746 annotate_field (5);
a6d9a66e 12747 *last_loc = b->loc;
f7f9143b
JB
12748 switch (ex)
12749 {
761269c8 12750 case ada_catch_exception:
28010a5d 12751 if (c->excep_string != NULL)
f7f9143b 12752 {
28010a5d
PA
12753 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12754
112e8700 12755 uiout->field_string ("what", msg);
f7f9143b
JB
12756 xfree (msg);
12757 }
12758 else
112e8700 12759 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12760
12761 break;
12762
761269c8 12763 case ada_catch_exception_unhandled:
112e8700 12764 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12765 break;
12766
9f757bf7
XR
12767 case ada_catch_handlers:
12768 if (c->excep_string != NULL)
12769 {
12770 uiout->field_fmt ("what",
12771 _("`%s' Ada exception handlers"),
12772 c->excep_string);
12773 }
12774 else
12775 uiout->field_string ("what", "all Ada exceptions handlers");
12776 break;
12777
761269c8 12778 case ada_catch_assert:
112e8700 12779 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12780 break;
12781
12782 default:
12783 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12784 break;
12785 }
12786}
12787
12788/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12789 for all exception catchpoint kinds. */
12790
12791static void
761269c8 12792print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12793 struct breakpoint *b)
12794{
28010a5d 12795 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12796 struct ui_out *uiout = current_uiout;
28010a5d 12797
112e8700 12798 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12799 : _("Catchpoint "));
112e8700
SM
12800 uiout->field_int ("bkptno", b->number);
12801 uiout->text (": ");
00eb2c4a 12802
f7f9143b
JB
12803 switch (ex)
12804 {
761269c8 12805 case ada_catch_exception:
28010a5d 12806 if (c->excep_string != NULL)
00eb2c4a
JB
12807 {
12808 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12809 struct cleanup *old_chain = make_cleanup (xfree, info);
12810
112e8700 12811 uiout->text (info);
00eb2c4a
JB
12812 do_cleanups (old_chain);
12813 }
f7f9143b 12814 else
112e8700 12815 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12816 break;
12817
761269c8 12818 case ada_catch_exception_unhandled:
112e8700 12819 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12820 break;
9f757bf7
XR
12821
12822 case ada_catch_handlers:
12823 if (c->excep_string != NULL)
12824 {
12825 std::string info
12826 = string_printf (_("`%s' Ada exception handlers"),
12827 c->excep_string);
12828 uiout->text (info.c_str ());
12829 }
12830 else
12831 uiout->text (_("all Ada exceptions handlers"));
12832 break;
12833
761269c8 12834 case ada_catch_assert:
112e8700 12835 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12836 break;
12837
12838 default:
12839 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12840 break;
12841 }
12842}
12843
6149aea9
PA
12844/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12845 for all exception catchpoint kinds. */
12846
12847static void
761269c8 12848print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12849 struct breakpoint *b, struct ui_file *fp)
12850{
28010a5d
PA
12851 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12852
6149aea9
PA
12853 switch (ex)
12854 {
761269c8 12855 case ada_catch_exception:
6149aea9 12856 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12857 if (c->excep_string != NULL)
12858 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12859 break;
12860
761269c8 12861 case ada_catch_exception_unhandled:
78076abc 12862 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12863 break;
12864
9f757bf7
XR
12865 case ada_catch_handlers:
12866 fprintf_filtered (fp, "catch handlers");
12867 break;
12868
761269c8 12869 case ada_catch_assert:
6149aea9
PA
12870 fprintf_filtered (fp, "catch assert");
12871 break;
12872
12873 default:
12874 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12875 }
d9b3f62e 12876 print_recreate_thread (b, fp);
6149aea9
PA
12877}
12878
f7f9143b
JB
12879/* Virtual table for "catch exception" breakpoints. */
12880
28010a5d
PA
12881static struct bp_location *
12882allocate_location_catch_exception (struct breakpoint *self)
12883{
761269c8 12884 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12885}
12886
12887static void
12888re_set_catch_exception (struct breakpoint *b)
12889{
761269c8 12890 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12891}
12892
12893static void
12894check_status_catch_exception (bpstat bs)
12895{
761269c8 12896 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12897}
12898
f7f9143b 12899static enum print_stop_action
348d480f 12900print_it_catch_exception (bpstat bs)
f7f9143b 12901{
761269c8 12902 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12903}
12904
12905static void
a6d9a66e 12906print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12907{
761269c8 12908 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12909}
12910
12911static void
12912print_mention_catch_exception (struct breakpoint *b)
12913{
761269c8 12914 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12915}
12916
6149aea9
PA
12917static void
12918print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12919{
761269c8 12920 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12921}
12922
2060206e 12923static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12924
12925/* Virtual table for "catch exception unhandled" breakpoints. */
12926
28010a5d
PA
12927static struct bp_location *
12928allocate_location_catch_exception_unhandled (struct breakpoint *self)
12929{
761269c8 12930 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12931}
12932
12933static void
12934re_set_catch_exception_unhandled (struct breakpoint *b)
12935{
761269c8 12936 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12937}
12938
12939static void
12940check_status_catch_exception_unhandled (bpstat bs)
12941{
761269c8 12942 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12943}
12944
f7f9143b 12945static enum print_stop_action
348d480f 12946print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12947{
761269c8 12948 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12949}
12950
12951static void
a6d9a66e
UW
12952print_one_catch_exception_unhandled (struct breakpoint *b,
12953 struct bp_location **last_loc)
f7f9143b 12954{
761269c8 12955 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12956}
12957
12958static void
12959print_mention_catch_exception_unhandled (struct breakpoint *b)
12960{
761269c8 12961 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12962}
12963
6149aea9
PA
12964static void
12965print_recreate_catch_exception_unhandled (struct breakpoint *b,
12966 struct ui_file *fp)
12967{
761269c8 12968 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12969}
12970
2060206e 12971static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12972
12973/* Virtual table for "catch assert" breakpoints. */
12974
28010a5d
PA
12975static struct bp_location *
12976allocate_location_catch_assert (struct breakpoint *self)
12977{
761269c8 12978 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12979}
12980
12981static void
12982re_set_catch_assert (struct breakpoint *b)
12983{
761269c8 12984 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12985}
12986
12987static void
12988check_status_catch_assert (bpstat bs)
12989{
761269c8 12990 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12991}
12992
f7f9143b 12993static enum print_stop_action
348d480f 12994print_it_catch_assert (bpstat bs)
f7f9143b 12995{
761269c8 12996 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12997}
12998
12999static void
a6d9a66e 13000print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 13001{
761269c8 13002 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
13003}
13004
13005static void
13006print_mention_catch_assert (struct breakpoint *b)
13007{
761269c8 13008 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
13009}
13010
6149aea9
PA
13011static void
13012print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
13013{
761269c8 13014 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
13015}
13016
2060206e 13017static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 13018
9f757bf7
XR
13019/* Virtual table for "catch handlers" breakpoints. */
13020
13021static struct bp_location *
13022allocate_location_catch_handlers (struct breakpoint *self)
13023{
13024 return allocate_location_exception (ada_catch_handlers, self);
13025}
13026
13027static void
13028re_set_catch_handlers (struct breakpoint *b)
13029{
13030 re_set_exception (ada_catch_handlers, b);
13031}
13032
13033static void
13034check_status_catch_handlers (bpstat bs)
13035{
13036 check_status_exception (ada_catch_handlers, bs);
13037}
13038
13039static enum print_stop_action
13040print_it_catch_handlers (bpstat bs)
13041{
13042 return print_it_exception (ada_catch_handlers, bs);
13043}
13044
13045static void
13046print_one_catch_handlers (struct breakpoint *b,
13047 struct bp_location **last_loc)
13048{
13049 print_one_exception (ada_catch_handlers, b, last_loc);
13050}
13051
13052static void
13053print_mention_catch_handlers (struct breakpoint *b)
13054{
13055 print_mention_exception (ada_catch_handlers, b);
13056}
13057
13058static void
13059print_recreate_catch_handlers (struct breakpoint *b,
13060 struct ui_file *fp)
13061{
13062 print_recreate_exception (ada_catch_handlers, b, fp);
13063}
13064
13065static struct breakpoint_ops catch_handlers_breakpoint_ops;
13066
f7f9143b
JB
13067/* Return a newly allocated copy of the first space-separated token
13068 in ARGSP, and then adjust ARGSP to point immediately after that
13069 token.
13070
13071 Return NULL if ARGPS does not contain any more tokens. */
13072
13073static char *
a121b7c1 13074ada_get_next_arg (const char **argsp)
f7f9143b 13075{
a121b7c1
PA
13076 const char *args = *argsp;
13077 const char *end;
f7f9143b
JB
13078 char *result;
13079
f1735a53 13080 args = skip_spaces (args);
f7f9143b
JB
13081 if (args[0] == '\0')
13082 return NULL; /* No more arguments. */
13083
13084 /* Find the end of the current argument. */
13085
f1735a53 13086 end = skip_to_space (args);
f7f9143b
JB
13087
13088 /* Adjust ARGSP to point to the start of the next argument. */
13089
13090 *argsp = end;
13091
13092 /* Make a copy of the current argument and return it. */
13093
224c3ddb 13094 result = (char *) xmalloc (end - args + 1);
f7f9143b
JB
13095 strncpy (result, args, end - args);
13096 result[end - args] = '\0';
13097
13098 return result;
13099}
13100
13101/* Split the arguments specified in a "catch exception" command.
13102 Set EX to the appropriate catchpoint type.
28010a5d 13103 Set EXCEP_STRING to the name of the specific exception if
5845583d 13104 specified by the user.
9f757bf7
XR
13105 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13106 "catch handlers" command. False otherwise.
5845583d
JB
13107 If a condition is found at the end of the arguments, the condition
13108 expression is stored in COND_STRING (memory must be deallocated
13109 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
13110
13111static void
a121b7c1 13112catch_ada_exception_command_split (const char *args,
9f757bf7 13113 bool is_catch_handlers_cmd,
761269c8 13114 enum ada_exception_catchpoint_kind *ex,
5845583d 13115 char **excep_string,
56ecd069 13116 std::string &cond_string)
f7f9143b
JB
13117{
13118 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
13119 char *exception_name;
5845583d 13120 char *cond = NULL;
f7f9143b
JB
13121
13122 exception_name = ada_get_next_arg (&args);
5845583d
JB
13123 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
13124 {
13125 /* This is not an exception name; this is the start of a condition
13126 expression for a catchpoint on all exceptions. So, "un-get"
13127 this token, and set exception_name to NULL. */
13128 xfree (exception_name);
13129 exception_name = NULL;
13130 args -= 2;
13131 }
f7f9143b
JB
13132 make_cleanup (xfree, exception_name);
13133
5845583d 13134 /* Check to see if we have a condition. */
f7f9143b 13135
f1735a53 13136 args = skip_spaces (args);
61012eef 13137 if (startswith (args, "if")
5845583d
JB
13138 && (isspace (args[2]) || args[2] == '\0'))
13139 {
13140 args += 2;
f1735a53 13141 args = skip_spaces (args);
5845583d
JB
13142
13143 if (args[0] == '\0')
13144 error (_("Condition missing after `if' keyword"));
13145 cond = xstrdup (args);
13146 make_cleanup (xfree, cond);
13147
13148 args += strlen (args);
13149 }
13150
13151 /* Check that we do not have any more arguments. Anything else
13152 is unexpected. */
f7f9143b
JB
13153
13154 if (args[0] != '\0')
13155 error (_("Junk at end of expression"));
13156
13157 discard_cleanups (old_chain);
13158
9f757bf7
XR
13159 if (is_catch_handlers_cmd)
13160 {
13161 /* Catch handling of exceptions. */
13162 *ex = ada_catch_handlers;
13163 *excep_string = exception_name;
13164 }
13165 else if (exception_name == NULL)
f7f9143b
JB
13166 {
13167 /* Catch all exceptions. */
761269c8 13168 *ex = ada_catch_exception;
28010a5d 13169 *excep_string = NULL;
f7f9143b
JB
13170 }
13171 else if (strcmp (exception_name, "unhandled") == 0)
13172 {
13173 /* Catch unhandled exceptions. */
761269c8 13174 *ex = ada_catch_exception_unhandled;
28010a5d 13175 *excep_string = NULL;
f7f9143b
JB
13176 }
13177 else
13178 {
13179 /* Catch a specific exception. */
761269c8 13180 *ex = ada_catch_exception;
28010a5d 13181 *excep_string = exception_name;
f7f9143b 13182 }
56ecd069
XR
13183 if (cond != NULL)
13184 cond_string.assign (cond);
f7f9143b
JB
13185}
13186
13187/* Return the name of the symbol on which we should break in order to
13188 implement a catchpoint of the EX kind. */
13189
13190static const char *
761269c8 13191ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 13192{
3eecfa55
JB
13193 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13194
13195 gdb_assert (data->exception_info != NULL);
0259addd 13196
f7f9143b
JB
13197 switch (ex)
13198 {
761269c8 13199 case ada_catch_exception:
3eecfa55 13200 return (data->exception_info->catch_exception_sym);
f7f9143b 13201 break;
761269c8 13202 case ada_catch_exception_unhandled:
3eecfa55 13203 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 13204 break;
761269c8 13205 case ada_catch_assert:
3eecfa55 13206 return (data->exception_info->catch_assert_sym);
f7f9143b 13207 break;
9f757bf7
XR
13208 case ada_catch_handlers:
13209 return (data->exception_info->catch_handlers_sym);
13210 break;
f7f9143b
JB
13211 default:
13212 internal_error (__FILE__, __LINE__,
13213 _("unexpected catchpoint kind (%d)"), ex);
13214 }
13215}
13216
13217/* Return the breakpoint ops "virtual table" used for catchpoints
13218 of the EX kind. */
13219
c0a91b2b 13220static const struct breakpoint_ops *
761269c8 13221ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
13222{
13223 switch (ex)
13224 {
761269c8 13225 case ada_catch_exception:
f7f9143b
JB
13226 return (&catch_exception_breakpoint_ops);
13227 break;
761269c8 13228 case ada_catch_exception_unhandled:
f7f9143b
JB
13229 return (&catch_exception_unhandled_breakpoint_ops);
13230 break;
761269c8 13231 case ada_catch_assert:
f7f9143b
JB
13232 return (&catch_assert_breakpoint_ops);
13233 break;
9f757bf7
XR
13234 case ada_catch_handlers:
13235 return (&catch_handlers_breakpoint_ops);
13236 break;
f7f9143b
JB
13237 default:
13238 internal_error (__FILE__, __LINE__,
13239 _("unexpected catchpoint kind (%d)"), ex);
13240 }
13241}
13242
13243/* Return the condition that will be used to match the current exception
13244 being raised with the exception that the user wants to catch. This
13245 assumes that this condition is used when the inferior just triggered
13246 an exception catchpoint.
cb7de75e 13247 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 13248
cb7de75e 13249static std::string
9f757bf7
XR
13250ada_exception_catchpoint_cond_string (const char *excep_string,
13251 enum ada_exception_catchpoint_kind ex)
f7f9143b 13252{
3d0b0fa3 13253 int i;
9f757bf7 13254 bool is_standard_exc = false;
cb7de75e 13255 std::string result;
9f757bf7
XR
13256
13257 if (ex == ada_catch_handlers)
13258 {
13259 /* For exception handlers catchpoints, the condition string does
13260 not use the same parameter as for the other exceptions. */
cb7de75e
TT
13261 result = ("long_integer (GNAT_GCC_exception_Access"
13262 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13263 }
13264 else
cb7de75e 13265 result = "long_integer (e)";
3d0b0fa3 13266
0963b4bd 13267 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13268 runtime units that have been compiled without debugging info; if
28010a5d 13269 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13270 exception (e.g. "constraint_error") then, during the evaluation
13271 of the condition expression, the symbol lookup on this name would
0963b4bd 13272 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13273 may then be set only on user-defined exceptions which have the
13274 same not-fully-qualified name (e.g. my_package.constraint_error).
13275
13276 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13277 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13278 exception constraint_error" is rewritten into "catch exception
13279 standard.constraint_error".
13280
13281 If an exception named contraint_error is defined in another package of
13282 the inferior program, then the only way to specify this exception as a
13283 breakpoint condition is to use its fully-qualified named:
13284 e.g. my_package.constraint_error. */
13285
13286 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13287 {
28010a5d 13288 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13289 {
9f757bf7
XR
13290 is_standard_exc = true;
13291 break;
3d0b0fa3
JB
13292 }
13293 }
9f757bf7 13294
cb7de75e
TT
13295 result += " = ";
13296
9f757bf7 13297 if (is_standard_exc)
cb7de75e 13298 string_appendf (result, "long_integer (&standard.%s)", excep_string);
9f757bf7 13299 else
cb7de75e 13300 string_appendf (result, "long_integer (&%s)", excep_string);
9f757bf7 13301
9f757bf7 13302 return result;
f7f9143b
JB
13303}
13304
13305/* Return the symtab_and_line that should be used to insert an exception
13306 catchpoint of the TYPE kind.
13307
28010a5d
PA
13308 EXCEP_STRING should contain the name of a specific exception that
13309 the catchpoint should catch, or NULL otherwise.
f7f9143b 13310
28010a5d
PA
13311 ADDR_STRING returns the name of the function where the real
13312 breakpoint that implements the catchpoints is set, depending on the
13313 type of catchpoint we need to create. */
f7f9143b
JB
13314
13315static struct symtab_and_line
761269c8 13316ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
f2fc3015 13317 const char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13318{
13319 const char *sym_name;
13320 struct symbol *sym;
f7f9143b 13321
0259addd
JB
13322 /* First, find out which exception support info to use. */
13323 ada_exception_support_info_sniffer ();
13324
13325 /* Then lookup the function on which we will break in order to catch
f7f9143b 13326 the Ada exceptions requested by the user. */
f7f9143b
JB
13327 sym_name = ada_exception_sym_name (ex);
13328 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13329
f17011e0
JB
13330 /* We can assume that SYM is not NULL at this stage. If the symbol
13331 did not exist, ada_exception_support_info_sniffer would have
13332 raised an exception.
f7f9143b 13333
f17011e0
JB
13334 Also, ada_exception_support_info_sniffer should have already
13335 verified that SYM is a function symbol. */
13336 gdb_assert (sym != NULL);
13337 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
13338
13339 /* Set ADDR_STRING. */
f7f9143b
JB
13340 *addr_string = xstrdup (sym_name);
13341
f7f9143b 13342 /* Set OPS. */
4b9eee8c 13343 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13344
f17011e0 13345 return find_function_start_sal (sym, 1);
f7f9143b
JB
13346}
13347
b4a5b78b 13348/* Create an Ada exception catchpoint.
f7f9143b 13349
b4a5b78b 13350 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13351
2df4d1d5
JB
13352 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
13353 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13354 of the exception to which this catchpoint applies. When not NULL,
13355 the string must be allocated on the heap, and its deallocation
13356 is no longer the responsibility of the caller.
13357
13358 COND_STRING, if not NULL, is the catchpoint condition. This string
13359 must be allocated on the heap, and its deallocation is no longer
13360 the responsibility of the caller.
f7f9143b 13361
b4a5b78b
JB
13362 TEMPFLAG, if nonzero, means that the underlying breakpoint
13363 should be temporary.
28010a5d 13364
b4a5b78b 13365 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13366
349774ef 13367void
28010a5d 13368create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13369 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 13370 char *excep_string,
56ecd069 13371 const std::string &cond_string,
28010a5d 13372 int tempflag,
349774ef 13373 int disabled,
28010a5d
PA
13374 int from_tty)
13375{
f2fc3015 13376 const char *addr_string = NULL;
b4a5b78b
JB
13377 const struct breakpoint_ops *ops = NULL;
13378 struct symtab_and_line sal
13379 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d 13380
b270e6f9
TT
13381 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13382 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
349774ef 13383 ops, tempflag, disabled, from_tty);
28010a5d 13384 c->excep_string = excep_string;
9f757bf7 13385 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13386 if (!cond_string.empty ())
13387 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13388 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13389}
13390
9ac4176b
PA
13391/* Implement the "catch exception" command. */
13392
13393static void
eb4c3f4a 13394catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13395 struct cmd_list_element *command)
13396{
a121b7c1 13397 const char *arg = arg_entry;
9ac4176b
PA
13398 struct gdbarch *gdbarch = get_current_arch ();
13399 int tempflag;
761269c8 13400 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 13401 char *excep_string = NULL;
56ecd069 13402 std::string cond_string;
9ac4176b
PA
13403
13404 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13405
13406 if (!arg)
13407 arg = "";
9f757bf7 13408 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
56ecd069 13409 cond_string);
9f757bf7
XR
13410 create_ada_exception_catchpoint (gdbarch, ex_kind,
13411 excep_string, cond_string,
13412 tempflag, 1 /* enabled */,
13413 from_tty);
13414}
13415
13416/* Implement the "catch handlers" command. */
13417
13418static void
13419catch_ada_handlers_command (const char *arg_entry, int from_tty,
13420 struct cmd_list_element *command)
13421{
13422 const char *arg = arg_entry;
13423 struct gdbarch *gdbarch = get_current_arch ();
13424 int tempflag;
13425 enum ada_exception_catchpoint_kind ex_kind;
13426 char *excep_string = NULL;
56ecd069 13427 std::string cond_string;
9f757bf7
XR
13428
13429 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13430
13431 if (!arg)
13432 arg = "";
13433 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
56ecd069 13434 cond_string);
b4a5b78b
JB
13435 create_ada_exception_catchpoint (gdbarch, ex_kind,
13436 excep_string, cond_string,
349774ef
JB
13437 tempflag, 1 /* enabled */,
13438 from_tty);
9ac4176b
PA
13439}
13440
b4a5b78b 13441/* Split the arguments specified in a "catch assert" command.
5845583d 13442
b4a5b78b
JB
13443 ARGS contains the command's arguments (or the empty string if
13444 no arguments were passed).
5845583d
JB
13445
13446 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13447 (the memory needs to be deallocated after use). */
5845583d 13448
b4a5b78b 13449static void
56ecd069 13450catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13451{
f1735a53 13452 args = skip_spaces (args);
f7f9143b 13453
5845583d 13454 /* Check whether a condition was provided. */
61012eef 13455 if (startswith (args, "if")
5845583d 13456 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13457 {
5845583d 13458 args += 2;
f1735a53 13459 args = skip_spaces (args);
5845583d
JB
13460 if (args[0] == '\0')
13461 error (_("condition missing after `if' keyword"));
56ecd069 13462 cond_string.assign (args);
f7f9143b
JB
13463 }
13464
5845583d
JB
13465 /* Otherwise, there should be no other argument at the end of
13466 the command. */
13467 else if (args[0] != '\0')
13468 error (_("Junk at end of arguments."));
f7f9143b
JB
13469}
13470
9ac4176b
PA
13471/* Implement the "catch assert" command. */
13472
13473static void
eb4c3f4a 13474catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13475 struct cmd_list_element *command)
13476{
a121b7c1 13477 const char *arg = arg_entry;
9ac4176b
PA
13478 struct gdbarch *gdbarch = get_current_arch ();
13479 int tempflag;
56ecd069 13480 std::string cond_string;
9ac4176b
PA
13481
13482 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13483
13484 if (!arg)
13485 arg = "";
56ecd069 13486 catch_ada_assert_command_split (arg, cond_string);
761269c8 13487 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 13488 NULL, cond_string,
349774ef
JB
13489 tempflag, 1 /* enabled */,
13490 from_tty);
9ac4176b 13491}
778865d3
JB
13492
13493/* Return non-zero if the symbol SYM is an Ada exception object. */
13494
13495static int
13496ada_is_exception_sym (struct symbol *sym)
13497{
13498 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13499
13500 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13501 && SYMBOL_CLASS (sym) != LOC_BLOCK
13502 && SYMBOL_CLASS (sym) != LOC_CONST
13503 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13504 && type_name != NULL && strcmp (type_name, "exception") == 0);
13505}
13506
13507/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13508 Ada exception object. This matches all exceptions except the ones
13509 defined by the Ada language. */
13510
13511static int
13512ada_is_non_standard_exception_sym (struct symbol *sym)
13513{
13514 int i;
13515
13516 if (!ada_is_exception_sym (sym))
13517 return 0;
13518
13519 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13520 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13521 return 0; /* A standard exception. */
13522
13523 /* Numeric_Error is also a standard exception, so exclude it.
13524 See the STANDARD_EXC description for more details as to why
13525 this exception is not listed in that array. */
13526 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13527 return 0;
13528
13529 return 1;
13530}
13531
ab816a27 13532/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13533 objects.
13534
13535 The comparison is determined first by exception name, and then
13536 by exception address. */
13537
ab816a27 13538bool
cc536b21 13539ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13540{
778865d3
JB
13541 int result;
13542
ab816a27
TT
13543 result = strcmp (name, other.name);
13544 if (result < 0)
13545 return true;
13546 if (result == 0 && addr < other.addr)
13547 return true;
13548 return false;
13549}
778865d3 13550
ab816a27 13551bool
cc536b21 13552ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13553{
13554 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13555}
13556
13557/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13558 routine, but keeping the first SKIP elements untouched.
13559
13560 All duplicates are also removed. */
13561
13562static void
ab816a27 13563sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13564 int skip)
13565{
ab816a27
TT
13566 std::sort (exceptions->begin () + skip, exceptions->end ());
13567 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13568 exceptions->end ());
778865d3
JB
13569}
13570
778865d3
JB
13571/* Add all exceptions defined by the Ada standard whose name match
13572 a regular expression.
13573
13574 If PREG is not NULL, then this regexp_t object is used to
13575 perform the symbol name matching. Otherwise, no name-based
13576 filtering is performed.
13577
13578 EXCEPTIONS is a vector of exceptions to which matching exceptions
13579 gets pushed. */
13580
13581static void
2d7cc5c7 13582ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13583 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13584{
13585 int i;
13586
13587 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13588 {
13589 if (preg == NULL
2d7cc5c7 13590 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13591 {
13592 struct bound_minimal_symbol msymbol
13593 = ada_lookup_simple_minsym (standard_exc[i]);
13594
13595 if (msymbol.minsym != NULL)
13596 {
13597 struct ada_exc_info info
77e371c0 13598 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13599
ab816a27 13600 exceptions->push_back (info);
778865d3
JB
13601 }
13602 }
13603 }
13604}
13605
13606/* Add all Ada exceptions defined locally and accessible from the given
13607 FRAME.
13608
13609 If PREG is not NULL, then this regexp_t object is used to
13610 perform the symbol name matching. Otherwise, no name-based
13611 filtering is performed.
13612
13613 EXCEPTIONS is a vector of exceptions to which matching exceptions
13614 gets pushed. */
13615
13616static void
2d7cc5c7
PA
13617ada_add_exceptions_from_frame (compiled_regex *preg,
13618 struct frame_info *frame,
ab816a27 13619 std::vector<ada_exc_info> *exceptions)
778865d3 13620{
3977b71f 13621 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13622
13623 while (block != 0)
13624 {
13625 struct block_iterator iter;
13626 struct symbol *sym;
13627
13628 ALL_BLOCK_SYMBOLS (block, iter, sym)
13629 {
13630 switch (SYMBOL_CLASS (sym))
13631 {
13632 case LOC_TYPEDEF:
13633 case LOC_BLOCK:
13634 case LOC_CONST:
13635 break;
13636 default:
13637 if (ada_is_exception_sym (sym))
13638 {
13639 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13640 SYMBOL_VALUE_ADDRESS (sym)};
13641
ab816a27 13642 exceptions->push_back (info);
778865d3
JB
13643 }
13644 }
13645 }
13646 if (BLOCK_FUNCTION (block) != NULL)
13647 break;
13648 block = BLOCK_SUPERBLOCK (block);
13649 }
13650}
13651
14bc53a8
PA
13652/* Return true if NAME matches PREG or if PREG is NULL. */
13653
13654static bool
2d7cc5c7 13655name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13656{
13657 return (preg == NULL
2d7cc5c7 13658 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13659}
13660
778865d3
JB
13661/* Add all exceptions defined globally whose name name match
13662 a regular expression, excluding standard exceptions.
13663
13664 The reason we exclude standard exceptions is that they need
13665 to be handled separately: Standard exceptions are defined inside
13666 a runtime unit which is normally not compiled with debugging info,
13667 and thus usually do not show up in our symbol search. However,
13668 if the unit was in fact built with debugging info, we need to
13669 exclude them because they would duplicate the entry we found
13670 during the special loop that specifically searches for those
13671 standard exceptions.
13672
13673 If PREG is not NULL, then this regexp_t object is used to
13674 perform the symbol name matching. Otherwise, no name-based
13675 filtering is performed.
13676
13677 EXCEPTIONS is a vector of exceptions to which matching exceptions
13678 gets pushed. */
13679
13680static void
2d7cc5c7 13681ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13682 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13683{
13684 struct objfile *objfile;
43f3e411 13685 struct compunit_symtab *s;
778865d3 13686
14bc53a8
PA
13687 /* In Ada, the symbol "search name" is a linkage name, whereas the
13688 regular expression used to do the matching refers to the natural
13689 name. So match against the decoded name. */
13690 expand_symtabs_matching (NULL,
b5ec771e 13691 lookup_name_info::match_any (),
14bc53a8
PA
13692 [&] (const char *search_name)
13693 {
13694 const char *decoded = ada_decode (search_name);
13695 return name_matches_regex (decoded, preg);
13696 },
13697 NULL,
13698 VARIABLES_DOMAIN);
778865d3 13699
43f3e411 13700 ALL_COMPUNITS (objfile, s)
778865d3 13701 {
43f3e411 13702 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13703 int i;
13704
13705 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13706 {
13707 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13708 struct block_iterator iter;
13709 struct symbol *sym;
13710
13711 ALL_BLOCK_SYMBOLS (b, iter, sym)
13712 if (ada_is_non_standard_exception_sym (sym)
14bc53a8 13713 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
778865d3
JB
13714 {
13715 struct ada_exc_info info
13716 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13717
ab816a27 13718 exceptions->push_back (info);
778865d3
JB
13719 }
13720 }
13721 }
13722}
13723
13724/* Implements ada_exceptions_list with the regular expression passed
13725 as a regex_t, rather than a string.
13726
13727 If not NULL, PREG is used to filter out exceptions whose names
13728 do not match. Otherwise, all exceptions are listed. */
13729
ab816a27 13730static std::vector<ada_exc_info>
2d7cc5c7 13731ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13732{
ab816a27 13733 std::vector<ada_exc_info> result;
778865d3
JB
13734 int prev_len;
13735
13736 /* First, list the known standard exceptions. These exceptions
13737 need to be handled separately, as they are usually defined in
13738 runtime units that have been compiled without debugging info. */
13739
13740 ada_add_standard_exceptions (preg, &result);
13741
13742 /* Next, find all exceptions whose scope is local and accessible
13743 from the currently selected frame. */
13744
13745 if (has_stack_frames ())
13746 {
ab816a27 13747 prev_len = result.size ();
778865d3
JB
13748 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13749 &result);
ab816a27 13750 if (result.size () > prev_len)
778865d3
JB
13751 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13752 }
13753
13754 /* Add all exceptions whose scope is global. */
13755
ab816a27 13756 prev_len = result.size ();
778865d3 13757 ada_add_global_exceptions (preg, &result);
ab816a27 13758 if (result.size () > prev_len)
778865d3
JB
13759 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13760
778865d3
JB
13761 return result;
13762}
13763
13764/* Return a vector of ada_exc_info.
13765
13766 If REGEXP is NULL, all exceptions are included in the result.
13767 Otherwise, it should contain a valid regular expression,
13768 and only the exceptions whose names match that regular expression
13769 are included in the result.
13770
13771 The exceptions are sorted in the following order:
13772 - Standard exceptions (defined by the Ada language), in
13773 alphabetical order;
13774 - Exceptions only visible from the current frame, in
13775 alphabetical order;
13776 - Exceptions whose scope is global, in alphabetical order. */
13777
ab816a27 13778std::vector<ada_exc_info>
778865d3
JB
13779ada_exceptions_list (const char *regexp)
13780{
2d7cc5c7
PA
13781 if (regexp == NULL)
13782 return ada_exceptions_list_1 (NULL);
778865d3 13783
2d7cc5c7
PA
13784 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13785 return ada_exceptions_list_1 (&reg);
778865d3
JB
13786}
13787
13788/* Implement the "info exceptions" command. */
13789
13790static void
1d12d88f 13791info_exceptions_command (const char *regexp, int from_tty)
778865d3 13792{
778865d3 13793 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13794
ab816a27 13795 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13796
13797 if (regexp != NULL)
13798 printf_filtered
13799 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13800 else
13801 printf_filtered (_("All defined Ada exceptions:\n"));
13802
ab816a27
TT
13803 for (const ada_exc_info &info : exceptions)
13804 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13805}
13806
4c4b4cd2
PH
13807 /* Operators */
13808/* Information about operators given special treatment in functions
13809 below. */
13810/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13811
13812#define ADA_OPERATORS \
13813 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13814 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13815 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13816 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13817 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13818 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13819 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13820 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13821 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13822 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13823 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13824 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13825 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13826 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13827 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13828 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13829 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13830 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13831 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13832
13833static void
554794dc
SDJ
13834ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13835 int *argsp)
4c4b4cd2
PH
13836{
13837 switch (exp->elts[pc - 1].opcode)
13838 {
76a01679 13839 default:
4c4b4cd2
PH
13840 operator_length_standard (exp, pc, oplenp, argsp);
13841 break;
13842
13843#define OP_DEFN(op, len, args, binop) \
13844 case op: *oplenp = len; *argsp = args; break;
13845 ADA_OPERATORS;
13846#undef OP_DEFN
52ce6436
PH
13847
13848 case OP_AGGREGATE:
13849 *oplenp = 3;
13850 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13851 break;
13852
13853 case OP_CHOICES:
13854 *oplenp = 3;
13855 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13856 break;
4c4b4cd2
PH
13857 }
13858}
13859
c0201579
JK
13860/* Implementation of the exp_descriptor method operator_check. */
13861
13862static int
13863ada_operator_check (struct expression *exp, int pos,
13864 int (*objfile_func) (struct objfile *objfile, void *data),
13865 void *data)
13866{
13867 const union exp_element *const elts = exp->elts;
13868 struct type *type = NULL;
13869
13870 switch (elts[pos].opcode)
13871 {
13872 case UNOP_IN_RANGE:
13873 case UNOP_QUAL:
13874 type = elts[pos + 1].type;
13875 break;
13876
13877 default:
13878 return operator_check_standard (exp, pos, objfile_func, data);
13879 }
13880
13881 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13882
13883 if (type && TYPE_OBJFILE (type)
13884 && (*objfile_func) (TYPE_OBJFILE (type), data))
13885 return 1;
13886
13887 return 0;
13888}
13889
a121b7c1 13890static const char *
4c4b4cd2
PH
13891ada_op_name (enum exp_opcode opcode)
13892{
13893 switch (opcode)
13894 {
76a01679 13895 default:
4c4b4cd2 13896 return op_name_standard (opcode);
52ce6436 13897
4c4b4cd2
PH
13898#define OP_DEFN(op, len, args, binop) case op: return #op;
13899 ADA_OPERATORS;
13900#undef OP_DEFN
52ce6436
PH
13901
13902 case OP_AGGREGATE:
13903 return "OP_AGGREGATE";
13904 case OP_CHOICES:
13905 return "OP_CHOICES";
13906 case OP_NAME:
13907 return "OP_NAME";
4c4b4cd2
PH
13908 }
13909}
13910
13911/* As for operator_length, but assumes PC is pointing at the first
13912 element of the operator, and gives meaningful results only for the
52ce6436 13913 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13914
13915static void
76a01679
JB
13916ada_forward_operator_length (struct expression *exp, int pc,
13917 int *oplenp, int *argsp)
4c4b4cd2 13918{
76a01679 13919 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13920 {
13921 default:
13922 *oplenp = *argsp = 0;
13923 break;
52ce6436 13924
4c4b4cd2
PH
13925#define OP_DEFN(op, len, args, binop) \
13926 case op: *oplenp = len; *argsp = args; break;
13927 ADA_OPERATORS;
13928#undef OP_DEFN
52ce6436
PH
13929
13930 case OP_AGGREGATE:
13931 *oplenp = 3;
13932 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13933 break;
13934
13935 case OP_CHOICES:
13936 *oplenp = 3;
13937 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13938 break;
13939
13940 case OP_STRING:
13941 case OP_NAME:
13942 {
13943 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13944
52ce6436
PH
13945 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13946 *argsp = 0;
13947 break;
13948 }
4c4b4cd2
PH
13949 }
13950}
13951
13952static int
13953ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13954{
13955 enum exp_opcode op = exp->elts[elt].opcode;
13956 int oplen, nargs;
13957 int pc = elt;
13958 int i;
76a01679 13959
4c4b4cd2
PH
13960 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13961
76a01679 13962 switch (op)
4c4b4cd2 13963 {
76a01679 13964 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13965 case OP_ATR_FIRST:
13966 case OP_ATR_LAST:
13967 case OP_ATR_LENGTH:
13968 case OP_ATR_IMAGE:
13969 case OP_ATR_MAX:
13970 case OP_ATR_MIN:
13971 case OP_ATR_MODULUS:
13972 case OP_ATR_POS:
13973 case OP_ATR_SIZE:
13974 case OP_ATR_TAG:
13975 case OP_ATR_VAL:
13976 break;
13977
13978 case UNOP_IN_RANGE:
13979 case UNOP_QUAL:
323e0a4a
AC
13980 /* XXX: gdb_sprint_host_address, type_sprint */
13981 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13982 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13983 fprintf_filtered (stream, " (");
13984 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13985 fprintf_filtered (stream, ")");
13986 break;
13987 case BINOP_IN_BOUNDS:
52ce6436
PH
13988 fprintf_filtered (stream, " (%d)",
13989 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13990 break;
13991 case TERNOP_IN_RANGE:
13992 break;
13993
52ce6436
PH
13994 case OP_AGGREGATE:
13995 case OP_OTHERS:
13996 case OP_DISCRETE_RANGE:
13997 case OP_POSITIONAL:
13998 case OP_CHOICES:
13999 break;
14000
14001 case OP_NAME:
14002 case OP_STRING:
14003 {
14004 char *name = &exp->elts[elt + 2].string;
14005 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 14006
52ce6436
PH
14007 fprintf_filtered (stream, "Text: `%.*s'", len, name);
14008 break;
14009 }
14010
4c4b4cd2
PH
14011 default:
14012 return dump_subexp_body_standard (exp, stream, elt);
14013 }
14014
14015 elt += oplen;
14016 for (i = 0; i < nargs; i += 1)
14017 elt = dump_subexp (exp, stream, elt);
14018
14019 return elt;
14020}
14021
14022/* The Ada extension of print_subexp (q.v.). */
14023
76a01679
JB
14024static void
14025ada_print_subexp (struct expression *exp, int *pos,
14026 struct ui_file *stream, enum precedence prec)
4c4b4cd2 14027{
52ce6436 14028 int oplen, nargs, i;
4c4b4cd2
PH
14029 int pc = *pos;
14030 enum exp_opcode op = exp->elts[pc].opcode;
14031
14032 ada_forward_operator_length (exp, pc, &oplen, &nargs);
14033
52ce6436 14034 *pos += oplen;
4c4b4cd2
PH
14035 switch (op)
14036 {
14037 default:
52ce6436 14038 *pos -= oplen;
4c4b4cd2
PH
14039 print_subexp_standard (exp, pos, stream, prec);
14040 return;
14041
14042 case OP_VAR_VALUE:
4c4b4cd2
PH
14043 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
14044 return;
14045
14046 case BINOP_IN_BOUNDS:
323e0a4a 14047 /* XXX: sprint_subexp */
4c4b4cd2 14048 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 14049 fputs_filtered (" in ", stream);
4c4b4cd2 14050 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 14051 fputs_filtered ("'range", stream);
4c4b4cd2 14052 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
14053 fprintf_filtered (stream, "(%ld)",
14054 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
14055 return;
14056
14057 case TERNOP_IN_RANGE:
4c4b4cd2 14058 if (prec >= PREC_EQUAL)
76a01679 14059 fputs_filtered ("(", stream);
323e0a4a 14060 /* XXX: sprint_subexp */
4c4b4cd2 14061 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 14062 fputs_filtered (" in ", stream);
4c4b4cd2
PH
14063 print_subexp (exp, pos, stream, PREC_EQUAL);
14064 fputs_filtered (" .. ", stream);
14065 print_subexp (exp, pos, stream, PREC_EQUAL);
14066 if (prec >= PREC_EQUAL)
76a01679
JB
14067 fputs_filtered (")", stream);
14068 return;
4c4b4cd2
PH
14069
14070 case OP_ATR_FIRST:
14071 case OP_ATR_LAST:
14072 case OP_ATR_LENGTH:
14073 case OP_ATR_IMAGE:
14074 case OP_ATR_MAX:
14075 case OP_ATR_MIN:
14076 case OP_ATR_MODULUS:
14077 case OP_ATR_POS:
14078 case OP_ATR_SIZE:
14079 case OP_ATR_TAG:
14080 case OP_ATR_VAL:
4c4b4cd2 14081 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
14082 {
14083 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
14084 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
14085 &type_print_raw_options);
76a01679
JB
14086 *pos += 3;
14087 }
4c4b4cd2 14088 else
76a01679 14089 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
14090 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
14091 if (nargs > 1)
76a01679
JB
14092 {
14093 int tem;
5b4ee69b 14094
76a01679
JB
14095 for (tem = 1; tem < nargs; tem += 1)
14096 {
14097 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
14098 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
14099 }
14100 fputs_filtered (")", stream);
14101 }
4c4b4cd2 14102 return;
14f9c5c9 14103
4c4b4cd2 14104 case UNOP_QUAL:
4c4b4cd2
PH
14105 type_print (exp->elts[pc + 1].type, "", stream, 0);
14106 fputs_filtered ("'(", stream);
14107 print_subexp (exp, pos, stream, PREC_PREFIX);
14108 fputs_filtered (")", stream);
14109 return;
14f9c5c9 14110
4c4b4cd2 14111 case UNOP_IN_RANGE:
323e0a4a 14112 /* XXX: sprint_subexp */
4c4b4cd2 14113 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 14114 fputs_filtered (" in ", stream);
79d43c61
TT
14115 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
14116 &type_print_raw_options);
4c4b4cd2 14117 return;
52ce6436
PH
14118
14119 case OP_DISCRETE_RANGE:
14120 print_subexp (exp, pos, stream, PREC_SUFFIX);
14121 fputs_filtered ("..", stream);
14122 print_subexp (exp, pos, stream, PREC_SUFFIX);
14123 return;
14124
14125 case OP_OTHERS:
14126 fputs_filtered ("others => ", stream);
14127 print_subexp (exp, pos, stream, PREC_SUFFIX);
14128 return;
14129
14130 case OP_CHOICES:
14131 for (i = 0; i < nargs-1; i += 1)
14132 {
14133 if (i > 0)
14134 fputs_filtered ("|", stream);
14135 print_subexp (exp, pos, stream, PREC_SUFFIX);
14136 }
14137 fputs_filtered (" => ", stream);
14138 print_subexp (exp, pos, stream, PREC_SUFFIX);
14139 return;
14140
14141 case OP_POSITIONAL:
14142 print_subexp (exp, pos, stream, PREC_SUFFIX);
14143 return;
14144
14145 case OP_AGGREGATE:
14146 fputs_filtered ("(", stream);
14147 for (i = 0; i < nargs; i += 1)
14148 {
14149 if (i > 0)
14150 fputs_filtered (", ", stream);
14151 print_subexp (exp, pos, stream, PREC_SUFFIX);
14152 }
14153 fputs_filtered (")", stream);
14154 return;
4c4b4cd2
PH
14155 }
14156}
14f9c5c9
AS
14157
14158/* Table mapping opcodes into strings for printing operators
14159 and precedences of the operators. */
14160
d2e4a39e
AS
14161static const struct op_print ada_op_print_tab[] = {
14162 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14163 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14164 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14165 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14166 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14167 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14168 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14169 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14170 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14171 {">=", BINOP_GEQ, PREC_ORDER, 0},
14172 {">", BINOP_GTR, PREC_ORDER, 0},
14173 {"<", BINOP_LESS, PREC_ORDER, 0},
14174 {">>", BINOP_RSH, PREC_SHIFT, 0},
14175 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14176 {"+", BINOP_ADD, PREC_ADD, 0},
14177 {"-", BINOP_SUB, PREC_ADD, 0},
14178 {"&", BINOP_CONCAT, PREC_ADD, 0},
14179 {"*", BINOP_MUL, PREC_MUL, 0},
14180 {"/", BINOP_DIV, PREC_MUL, 0},
14181 {"rem", BINOP_REM, PREC_MUL, 0},
14182 {"mod", BINOP_MOD, PREC_MUL, 0},
14183 {"**", BINOP_EXP, PREC_REPEAT, 0},
14184 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14185 {"-", UNOP_NEG, PREC_PREFIX, 0},
14186 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14187 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14188 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14189 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
14190 {".all", UNOP_IND, PREC_SUFFIX, 1},
14191 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14192 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 14193 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
14194};
14195\f
72d5681a
PH
14196enum ada_primitive_types {
14197 ada_primitive_type_int,
14198 ada_primitive_type_long,
14199 ada_primitive_type_short,
14200 ada_primitive_type_char,
14201 ada_primitive_type_float,
14202 ada_primitive_type_double,
14203 ada_primitive_type_void,
14204 ada_primitive_type_long_long,
14205 ada_primitive_type_long_double,
14206 ada_primitive_type_natural,
14207 ada_primitive_type_positive,
14208 ada_primitive_type_system_address,
08f49010 14209 ada_primitive_type_storage_offset,
72d5681a
PH
14210 nr_ada_primitive_types
14211};
6c038f32
PH
14212
14213static void
d4a9a881 14214ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
14215 struct language_arch_info *lai)
14216{
d4a9a881 14217 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 14218
72d5681a 14219 lai->primitive_type_vector
d4a9a881 14220 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 14221 struct type *);
e9bb382b
UW
14222
14223 lai->primitive_type_vector [ada_primitive_type_int]
14224 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14225 0, "integer");
14226 lai->primitive_type_vector [ada_primitive_type_long]
14227 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14228 0, "long_integer");
14229 lai->primitive_type_vector [ada_primitive_type_short]
14230 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14231 0, "short_integer");
14232 lai->string_char_type
14233 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 14234 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
14235 lai->primitive_type_vector [ada_primitive_type_float]
14236 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 14237 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
14238 lai->primitive_type_vector [ada_primitive_type_double]
14239 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14240 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14241 lai->primitive_type_vector [ada_primitive_type_long_long]
14242 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14243 0, "long_long_integer");
14244 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14245 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14246 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14247 lai->primitive_type_vector [ada_primitive_type_natural]
14248 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14249 0, "natural");
14250 lai->primitive_type_vector [ada_primitive_type_positive]
14251 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14252 0, "positive");
14253 lai->primitive_type_vector [ada_primitive_type_void]
14254 = builtin->builtin_void;
14255
14256 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14257 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14258 "void"));
72d5681a
PH
14259 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14260 = "system__address";
fbb06eb1 14261
08f49010
XR
14262 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14263 type. This is a signed integral type whose size is the same as
14264 the size of addresses. */
14265 {
14266 unsigned int addr_length = TYPE_LENGTH
14267 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14268
14269 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14270 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14271 "storage_offset");
14272 }
14273
47e729a8 14274 lai->bool_type_symbol = NULL;
fbb06eb1 14275 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14276}
6c038f32
PH
14277\f
14278 /* Language vector */
14279
14280/* Not really used, but needed in the ada_language_defn. */
14281
14282static void
6c7a06a3 14283emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14284{
6c7a06a3 14285 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14286}
14287
14288static int
410a0ff2 14289parse (struct parser_state *ps)
6c038f32
PH
14290{
14291 warnings_issued = 0;
410a0ff2 14292 return ada_parse (ps);
6c038f32
PH
14293}
14294
14295static const struct exp_descriptor ada_exp_descriptor = {
14296 ada_print_subexp,
14297 ada_operator_length,
c0201579 14298 ada_operator_check,
6c038f32
PH
14299 ada_op_name,
14300 ada_dump_subexp_body,
14301 ada_evaluate_subexp
14302};
14303
b5ec771e
PA
14304/* symbol_name_matcher_ftype adapter for wild_match. */
14305
14306static bool
14307do_wild_match (const char *symbol_search_name,
14308 const lookup_name_info &lookup_name,
a207cff2 14309 completion_match_result *comp_match_res)
b5ec771e
PA
14310{
14311 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14312}
14313
14314/* symbol_name_matcher_ftype adapter for full_match. */
14315
14316static bool
14317do_full_match (const char *symbol_search_name,
14318 const lookup_name_info &lookup_name,
a207cff2 14319 completion_match_result *comp_match_res)
b5ec771e
PA
14320{
14321 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14322}
14323
14324/* Build the Ada lookup name for LOOKUP_NAME. */
14325
14326ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14327{
14328 const std::string &user_name = lookup_name.name ();
14329
14330 if (user_name[0] == '<')
14331 {
14332 if (user_name.back () == '>')
14333 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14334 else
14335 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14336 m_encoded_p = true;
14337 m_verbatim_p = true;
14338 m_wild_match_p = false;
14339 m_standard_p = false;
14340 }
14341 else
14342 {
14343 m_verbatim_p = false;
14344
14345 m_encoded_p = user_name.find ("__") != std::string::npos;
14346
14347 if (!m_encoded_p)
14348 {
14349 const char *folded = ada_fold_name (user_name.c_str ());
14350 const char *encoded = ada_encode_1 (folded, false);
14351 if (encoded != NULL)
14352 m_encoded_name = encoded;
14353 else
14354 m_encoded_name = user_name;
14355 }
14356 else
14357 m_encoded_name = user_name;
14358
14359 /* Handle the 'package Standard' special case. See description
14360 of m_standard_p. */
14361 if (startswith (m_encoded_name.c_str (), "standard__"))
14362 {
14363 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14364 m_standard_p = true;
14365 }
14366 else
14367 m_standard_p = false;
74ccd7f5 14368
b5ec771e
PA
14369 /* If the name contains a ".", then the user is entering a fully
14370 qualified entity name, and the match must not be done in wild
14371 mode. Similarly, if the user wants to complete what looks
14372 like an encoded name, the match must not be done in wild
14373 mode. Also, in the standard__ special case always do
14374 non-wild matching. */
14375 m_wild_match_p
14376 = (lookup_name.match_type () != symbol_name_match_type::FULL
14377 && !m_encoded_p
14378 && !m_standard_p
14379 && user_name.find ('.') == std::string::npos);
14380 }
14381}
14382
14383/* symbol_name_matcher_ftype method for Ada. This only handles
14384 completion mode. */
14385
14386static bool
14387ada_symbol_name_matches (const char *symbol_search_name,
14388 const lookup_name_info &lookup_name,
a207cff2 14389 completion_match_result *comp_match_res)
74ccd7f5 14390{
b5ec771e
PA
14391 return lookup_name.ada ().matches (symbol_search_name,
14392 lookup_name.match_type (),
a207cff2 14393 comp_match_res);
b5ec771e
PA
14394}
14395
de63c46b
PA
14396/* A name matcher that matches the symbol name exactly, with
14397 strcmp. */
14398
14399static bool
14400literal_symbol_name_matcher (const char *symbol_search_name,
14401 const lookup_name_info &lookup_name,
14402 completion_match_result *comp_match_res)
14403{
14404 const std::string &name = lookup_name.name ();
14405
14406 int cmp = (lookup_name.completion_mode ()
14407 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14408 : strcmp (symbol_search_name, name.c_str ()));
14409 if (cmp == 0)
14410 {
14411 if (comp_match_res != NULL)
14412 comp_match_res->set_match (symbol_search_name);
14413 return true;
14414 }
14415 else
14416 return false;
14417}
14418
b5ec771e
PA
14419/* Implement the "la_get_symbol_name_matcher" language_defn method for
14420 Ada. */
14421
14422static symbol_name_matcher_ftype *
14423ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14424{
de63c46b
PA
14425 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14426 return literal_symbol_name_matcher;
14427
b5ec771e
PA
14428 if (lookup_name.completion_mode ())
14429 return ada_symbol_name_matches;
74ccd7f5 14430 else
b5ec771e
PA
14431 {
14432 if (lookup_name.ada ().wild_match_p ())
14433 return do_wild_match;
14434 else
14435 return do_full_match;
14436 }
74ccd7f5
JB
14437}
14438
a5ee536b
JB
14439/* Implement the "la_read_var_value" language_defn method for Ada. */
14440
14441static struct value *
63e43d3a
PMR
14442ada_read_var_value (struct symbol *var, const struct block *var_block,
14443 struct frame_info *frame)
a5ee536b 14444{
3977b71f 14445 const struct block *frame_block = NULL;
a5ee536b
JB
14446 struct symbol *renaming_sym = NULL;
14447
14448 /* The only case where default_read_var_value is not sufficient
14449 is when VAR is a renaming... */
14450 if (frame)
14451 frame_block = get_frame_block (frame, NULL);
14452 if (frame_block)
14453 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14454 if (renaming_sym != NULL)
14455 return ada_read_renaming_var_value (renaming_sym, frame_block);
14456
14457 /* This is a typical case where we expect the default_read_var_value
14458 function to work. */
63e43d3a 14459 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14460}
14461
56618e20
TT
14462static const char *ada_extensions[] =
14463{
14464 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14465};
14466
47e77640 14467extern const struct language_defn ada_language_defn = {
6c038f32 14468 "ada", /* Language name */
6abde28f 14469 "Ada",
6c038f32 14470 language_ada,
6c038f32 14471 range_check_off,
6c038f32
PH
14472 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14473 that's not quite what this means. */
6c038f32 14474 array_row_major,
9a044a89 14475 macro_expansion_no,
56618e20 14476 ada_extensions,
6c038f32
PH
14477 &ada_exp_descriptor,
14478 parse,
b3f11165 14479 ada_yyerror,
6c038f32
PH
14480 resolve,
14481 ada_printchar, /* Print a character constant */
14482 ada_printstr, /* Function to print string constant */
14483 emit_char, /* Function to print single char (not used) */
6c038f32 14484 ada_print_type, /* Print a type using appropriate syntax */
be942545 14485 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14486 ada_val_print, /* Print a value using appropriate syntax */
14487 ada_value_print, /* Print a top-level value */
a5ee536b 14488 ada_read_var_value, /* la_read_var_value */
6c038f32 14489 NULL, /* Language specific skip_trampoline */
2b2d9e11 14490 NULL, /* name_of_this */
59cc4834 14491 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14492 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14493 basic_lookup_transparent_type, /* lookup_transparent_type */
14494 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14495 ada_sniff_from_mangled_name,
0963b4bd
MS
14496 NULL, /* Language specific
14497 class_name_from_physname */
6c038f32
PH
14498 ada_op_print_tab, /* expression operators for printing */
14499 0, /* c-style arrays */
14500 1, /* String lower bound */
6c038f32 14501 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14502 ada_collect_symbol_completion_matches,
72d5681a 14503 ada_language_arch_info,
e79af960 14504 ada_print_array_index,
41f1b697 14505 default_pass_by_reference,
ae6a3a4c 14506 c_get_string,
43cc5389 14507 c_watch_location_expression,
b5ec771e 14508 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14509 ada_iterate_over_symbols,
5ffa0793 14510 default_search_name_hash,
a53b64ea 14511 &ada_varobj_ops,
bb2ec1b3
TT
14512 NULL,
14513 NULL,
6c038f32
PH
14514 LANG_MAGIC
14515};
14516
5bf03f13
JB
14517/* Command-list for the "set/show ada" prefix command. */
14518static struct cmd_list_element *set_ada_list;
14519static struct cmd_list_element *show_ada_list;
14520
14521/* Implement the "set ada" prefix command. */
14522
14523static void
981a3fb3 14524set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14525{
14526 printf_unfiltered (_(\
14527"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14528 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14529}
14530
14531/* Implement the "show ada" prefix command. */
14532
14533static void
981a3fb3 14534show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14535{
14536 cmd_show_list (show_ada_list, from_tty, "");
14537}
14538
2060206e
PA
14539static void
14540initialize_ada_catchpoint_ops (void)
14541{
14542 struct breakpoint_ops *ops;
14543
14544 initialize_breakpoint_ops ();
14545
14546 ops = &catch_exception_breakpoint_ops;
14547 *ops = bkpt_breakpoint_ops;
2060206e
PA
14548 ops->allocate_location = allocate_location_catch_exception;
14549 ops->re_set = re_set_catch_exception;
14550 ops->check_status = check_status_catch_exception;
14551 ops->print_it = print_it_catch_exception;
14552 ops->print_one = print_one_catch_exception;
14553 ops->print_mention = print_mention_catch_exception;
14554 ops->print_recreate = print_recreate_catch_exception;
14555
14556 ops = &catch_exception_unhandled_breakpoint_ops;
14557 *ops = bkpt_breakpoint_ops;
2060206e
PA
14558 ops->allocate_location = allocate_location_catch_exception_unhandled;
14559 ops->re_set = re_set_catch_exception_unhandled;
14560 ops->check_status = check_status_catch_exception_unhandled;
14561 ops->print_it = print_it_catch_exception_unhandled;
14562 ops->print_one = print_one_catch_exception_unhandled;
14563 ops->print_mention = print_mention_catch_exception_unhandled;
14564 ops->print_recreate = print_recreate_catch_exception_unhandled;
14565
14566 ops = &catch_assert_breakpoint_ops;
14567 *ops = bkpt_breakpoint_ops;
2060206e
PA
14568 ops->allocate_location = allocate_location_catch_assert;
14569 ops->re_set = re_set_catch_assert;
14570 ops->check_status = check_status_catch_assert;
14571 ops->print_it = print_it_catch_assert;
14572 ops->print_one = print_one_catch_assert;
14573 ops->print_mention = print_mention_catch_assert;
14574 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14575
14576 ops = &catch_handlers_breakpoint_ops;
14577 *ops = bkpt_breakpoint_ops;
14578 ops->allocate_location = allocate_location_catch_handlers;
14579 ops->re_set = re_set_catch_handlers;
14580 ops->check_status = check_status_catch_handlers;
14581 ops->print_it = print_it_catch_handlers;
14582 ops->print_one = print_one_catch_handlers;
14583 ops->print_mention = print_mention_catch_handlers;
14584 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14585}
14586
3d9434b5
JB
14587/* This module's 'new_objfile' observer. */
14588
14589static void
14590ada_new_objfile_observer (struct objfile *objfile)
14591{
14592 ada_clear_symbol_cache ();
14593}
14594
14595/* This module's 'free_objfile' observer. */
14596
14597static void
14598ada_free_objfile_observer (struct objfile *objfile)
14599{
14600 ada_clear_symbol_cache ();
14601}
14602
d2e4a39e 14603void
6c038f32 14604_initialize_ada_language (void)
14f9c5c9 14605{
2060206e
PA
14606 initialize_ada_catchpoint_ops ();
14607
5bf03f13
JB
14608 add_prefix_cmd ("ada", no_class, set_ada_command,
14609 _("Prefix command for changing Ada-specfic settings"),
14610 &set_ada_list, "set ada ", 0, &setlist);
14611
14612 add_prefix_cmd ("ada", no_class, show_ada_command,
14613 _("Generic command for showing Ada-specific settings."),
14614 &show_ada_list, "show ada ", 0, &showlist);
14615
14616 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14617 &trust_pad_over_xvs, _("\
14618Enable or disable an optimization trusting PAD types over XVS types"), _("\
14619Show whether an optimization trusting PAD types over XVS types is activated"),
14620 _("\
14621This is related to the encoding used by the GNAT compiler. The debugger\n\
14622should normally trust the contents of PAD types, but certain older versions\n\
14623of GNAT have a bug that sometimes causes the information in the PAD type\n\
14624to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14625work around this bug. It is always safe to turn this option \"off\", but\n\
14626this incurs a slight performance penalty, so it is recommended to NOT change\n\
14627this option to \"off\" unless necessary."),
14628 NULL, NULL, &set_ada_list, &show_ada_list);
14629
d72413e6
PMR
14630 add_setshow_boolean_cmd ("print-signatures", class_vars,
14631 &print_signatures, _("\
14632Enable or disable the output of formal and return types for functions in the \
14633overloads selection menu"), _("\
14634Show whether the output of formal and return types for functions in the \
14635overloads selection menu is activated"),
14636 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14637
9ac4176b
PA
14638 add_catch_command ("exception", _("\
14639Catch Ada exceptions, when raised.\n\
14640With an argument, catch only exceptions with the given name."),
14641 catch_ada_exception_command,
14642 NULL,
14643 CATCH_PERMANENT,
14644 CATCH_TEMPORARY);
9f757bf7
XR
14645
14646 add_catch_command ("handlers", _("\
14647Catch Ada exceptions, when handled.\n\
14648With an argument, catch only exceptions with the given name."),
14649 catch_ada_handlers_command,
14650 NULL,
14651 CATCH_PERMANENT,
14652 CATCH_TEMPORARY);
9ac4176b
PA
14653 add_catch_command ("assert", _("\
14654Catch failed Ada assertions, when raised.\n\
14655With an argument, catch only exceptions with the given name."),
14656 catch_assert_command,
14657 NULL,
14658 CATCH_PERMANENT,
14659 CATCH_TEMPORARY);
14660
6c038f32 14661 varsize_limit = 65536;
3fcded8f
JB
14662 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14663 &varsize_limit, _("\
14664Set the maximum number of bytes allowed in a variable-size object."), _("\
14665Show the maximum number of bytes allowed in a variable-size object."), _("\
14666Attempts to access an object whose size is not a compile-time constant\n\
14667and exceeds this limit will cause an error."),
14668 NULL, NULL, &setlist, &showlist);
6c038f32 14669
778865d3
JB
14670 add_info ("exceptions", info_exceptions_command,
14671 _("\
14672List all Ada exception names.\n\
14673If a regular expression is passed as an argument, only those matching\n\
14674the regular expression are listed."));
14675
c6044dd1
JB
14676 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14677 _("Set Ada maintenance-related variables."),
14678 &maint_set_ada_cmdlist, "maintenance set ada ",
14679 0/*allow-unknown*/, &maintenance_set_cmdlist);
14680
14681 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14682 _("Show Ada maintenance-related variables"),
14683 &maint_show_ada_cmdlist, "maintenance show ada ",
14684 0/*allow-unknown*/, &maintenance_show_cmdlist);
14685
14686 add_setshow_boolean_cmd
14687 ("ignore-descriptive-types", class_maintenance,
14688 &ada_ignore_descriptive_types_p,
14689 _("Set whether descriptive types generated by GNAT should be ignored."),
14690 _("Show whether descriptive types generated by GNAT should be ignored."),
14691 _("\
14692When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14693DWARF attribute."),
14694 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14695
459a2e4c
TT
14696 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14697 NULL, xcalloc, xfree);
6b69afc4 14698
3d9434b5 14699 /* The ada-lang observers. */
76727919
TT
14700 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14701 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14702 gdb::observers::inferior_exit.attach (ada_inferior_exit);
ee01b665
JB
14703
14704 /* Setup various context-specific data. */
e802dbe0 14705 ada_inferior_data
8e260fc0 14706 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14707 ada_pspace_data_handle
14708 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14709}