]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Make exceptions use std::string and be self-managing
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
42a4f53d 3 Copyright (C) 1992-2019 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"
d55e5aa6 24#include "gdb_regex.h"
4de283e4
TT
25#include "frame.h"
26#include "symtab.h"
27#include "gdbtypes.h"
14f9c5c9 28#include "gdbcmd.h"
4de283e4
TT
29#include "expression.h"
30#include "parser-defs.h"
31#include "language.h"
32#include "varobj.h"
33#include "c-lang.h"
34#include "inferior.h"
35#include "symfile.h"
36#include "objfiles.h"
37#include "breakpoint.h"
14f9c5c9 38#include "gdbcore.h"
4c4b4cd2 39#include "hashtab.h"
4de283e4
TT
40#include "gdb_obstack.h"
41#include "ada-lang.h"
42#include "completer.h"
43#include <sys/stat.h>
44#include "ui-out.h"
45#include "block.h"
04714b91 46#include "infcall.h"
4de283e4
TT
47#include "dictionary.h"
48#include "annotate.h"
49#include "valprint.h"
d55e5aa6 50#include "source.h"
4de283e4
TT
51#include "observable.h"
52#include "common/vec.h"
692465f1 53#include "stack.h"
4de283e4 54#include "common/gdb_vecs.h"
79d43c61 55#include "typeprint.h"
4de283e4
TT
56#include "namespace.h"
57
58#include "psymtab.h"
40bc484c 59#include "value.h"
4de283e4
TT
60#include "mi/mi-common.h"
61#include "arch-utils.h"
62#include "cli/cli-utils.h"
63#include "common/function-view.h"
64#include "common/byte-vector.h"
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,
699bd4cf
TT
128 struct type *, int,
129 innermost_block_tracker *);
14f9c5c9 130
e9d9f57e 131static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 132 struct symbol *, const struct block *);
14f9c5c9 133
d2e4a39e 134static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 135
a121b7c1 136static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
137
138static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 139
d2e4a39e 140static int numeric_type_p (struct type *);
14f9c5c9 141
d2e4a39e 142static int integer_type_p (struct type *);
14f9c5c9 143
d2e4a39e 144static int scalar_type_p (struct type *);
14f9c5c9 145
d2e4a39e 146static int discrete_type_p (struct type *);
14f9c5c9 147
aeb5907d
JB
148static enum ada_renaming_category parse_old_style_renaming (struct type *,
149 const char **,
150 int *,
151 const char **);
152
153static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 154 const struct block *);
aeb5907d 155
a121b7c1 156static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 157 int, int);
4c4b4cd2 158
d2e4a39e 159static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 160
b4ba55a1
JB
161static struct type *ada_find_parallel_type_with_name (struct type *,
162 const char *);
163
d2e4a39e 164static int is_dynamic_field (struct type *, int);
14f9c5c9 165
10a2c479 166static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 167 const gdb_byte *,
4c4b4cd2
PH
168 CORE_ADDR, struct value *);
169
170static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 171
28c85d6c 172static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 173
d2e4a39e 174static struct type *to_static_fixed_type (struct type *);
f192137b 175static struct type *static_unwrap_type (struct type *type);
14f9c5c9 176
d2e4a39e 177static struct value *unwrap_value (struct value *);
14f9c5c9 178
ad82864c 179static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 180
ad82864c 181static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 182
ad82864c
JB
183static long decode_packed_array_bitsize (struct type *);
184
185static struct value *decode_constrained_packed_array (struct value *);
186
187static int ada_is_packed_array_type (struct type *);
188
189static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 190
d2e4a39e 191static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 192 struct value **);
14f9c5c9 193
4c4b4cd2
PH
194static struct value *coerce_unspec_val_to_type (struct value *,
195 struct type *);
14f9c5c9 196
d2e4a39e 197static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 198
d2e4a39e 199static int equiv_types (struct type *, struct type *);
14f9c5c9 200
d2e4a39e 201static int is_name_suffix (const char *);
14f9c5c9 202
73589123
PH
203static int advance_wild_match (const char **, const char *, int);
204
b5ec771e 205static bool wild_match (const char *name, const char *patn);
14f9c5c9 206
d2e4a39e 207static struct value *ada_coerce_ref (struct value *);
14f9c5c9 208
4c4b4cd2
PH
209static LONGEST pos_atr (struct value *);
210
3cb382c9 211static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 212
d2e4a39e 213static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 214
4c4b4cd2
PH
215static struct symbol *standard_lookup (const char *, const struct block *,
216 domain_enum);
14f9c5c9 217
108d56a4 218static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
219 struct type *);
220
221static struct value *ada_value_primitive_field (struct value *, int, int,
222 struct type *);
223
0d5cff50 224static int find_struct_field (const char *, struct type *, int,
52ce6436 225 struct type **, int *, int *, int *, int *);
4c4b4cd2 226
d12307c1 227static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2 228 struct value **, int, const char *,
2a612529 229 struct type *, int);
4c4b4cd2 230
4c4b4cd2
PH
231static int ada_is_direct_array_type (struct type *);
232
72d5681a
PH
233static void ada_language_arch_info (struct gdbarch *,
234 struct language_arch_info *);
714e53ab 235
52ce6436
PH
236static struct value *ada_index_struct_field (int, struct value *, int,
237 struct type *);
238
239static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
240 struct expression *,
241 int *, enum noside);
52ce6436
PH
242
243static void aggregate_assign_from_choices (struct value *, struct value *,
244 struct expression *,
245 int *, LONGEST *, int *,
246 int, LONGEST, LONGEST);
247
248static void aggregate_assign_positional (struct value *, struct value *,
249 struct expression *,
250 int *, LONGEST *, int *, int,
251 LONGEST, LONGEST);
252
253
254static void aggregate_assign_others (struct value *, struct value *,
255 struct expression *,
256 int *, LONGEST *, int, LONGEST, LONGEST);
257
258
259static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
260
261
262static struct value *ada_evaluate_subexp (struct type *, struct expression *,
263 int *, enum noside);
264
265static void ada_forward_operator_length (struct expression *, int, int *,
266 int *);
852dff6c
JB
267
268static struct type *ada_find_any_type (const char *name);
b5ec771e
PA
269
270static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
271 (const lookup_name_info &lookup_name);
272
4c4b4cd2
PH
273\f
274
ee01b665
JB
275/* The result of a symbol lookup to be stored in our symbol cache. */
276
277struct cache_entry
278{
279 /* The name used to perform the lookup. */
280 const char *name;
281 /* The namespace used during the lookup. */
fe978cb0 282 domain_enum domain;
ee01b665
JB
283 /* The symbol returned by the lookup, or NULL if no matching symbol
284 was found. */
285 struct symbol *sym;
286 /* The block where the symbol was found, or NULL if no matching
287 symbol was found. */
288 const struct block *block;
289 /* A pointer to the next entry with the same hash. */
290 struct cache_entry *next;
291};
292
293/* The Ada symbol cache, used to store the result of Ada-mode symbol
294 lookups in the course of executing the user's commands.
295
296 The cache is implemented using a simple, fixed-sized hash.
297 The size is fixed on the grounds that there are not likely to be
298 all that many symbols looked up during any given session, regardless
299 of the size of the symbol table. If we decide to go to a resizable
300 table, let's just use the stuff from libiberty instead. */
301
302#define HASH_SIZE 1009
303
304struct ada_symbol_cache
305{
306 /* An obstack used to store the entries in our cache. */
307 struct obstack cache_space;
308
309 /* The root of the hash table used to implement our symbol cache. */
310 struct cache_entry *root[HASH_SIZE];
311};
312
313static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 314
4c4b4cd2 315/* Maximum-sized dynamic type. */
14f9c5c9
AS
316static unsigned int varsize_limit;
317
67cb5b2d 318static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
319#ifdef VMS
320 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
321#else
14f9c5c9 322 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 323#endif
14f9c5c9 324
4c4b4cd2 325/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 326static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 327 = "__gnat_ada_main_program_name";
14f9c5c9 328
4c4b4cd2
PH
329/* Limit on the number of warnings to raise per expression evaluation. */
330static int warning_limit = 2;
331
332/* Number of warning messages issued; reset to 0 by cleanups after
333 expression evaluation. */
334static int warnings_issued = 0;
335
336static const char *known_runtime_file_name_patterns[] = {
337 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
338};
339
340static const char *known_auxiliary_function_name_patterns[] = {
341 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
342};
343
c6044dd1
JB
344/* Maintenance-related settings for this module. */
345
346static struct cmd_list_element *maint_set_ada_cmdlist;
347static struct cmd_list_element *maint_show_ada_cmdlist;
348
349/* Implement the "maintenance set ada" (prefix) command. */
350
351static void
981a3fb3 352maint_set_ada_cmd (const char *args, int from_tty)
c6044dd1 353{
635c7e8a
TT
354 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
355 gdb_stdout);
c6044dd1
JB
356}
357
358/* Implement the "maintenance show ada" (prefix) command. */
359
360static void
981a3fb3 361maint_show_ada_cmd (const char *args, int from_tty)
c6044dd1
JB
362{
363 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
364}
365
366/* The "maintenance ada set/show ignore-descriptive-type" value. */
367
368static int ada_ignore_descriptive_types_p = 0;
369
e802dbe0
JB
370 /* Inferior-specific data. */
371
372/* Per-inferior data for this module. */
373
374struct ada_inferior_data
375{
376 /* The ada__tags__type_specific_data type, which is used when decoding
377 tagged types. With older versions of GNAT, this type was directly
378 accessible through a component ("tsd") in the object tag. But this
379 is no longer the case, so we cache it for each inferior. */
380 struct type *tsd_type;
3eecfa55
JB
381
382 /* The exception_support_info data. This data is used to determine
383 how to implement support for Ada exception catchpoints in a given
384 inferior. */
385 const struct exception_support_info *exception_info;
e802dbe0
JB
386};
387
388/* Our key to this module's inferior data. */
389static const struct inferior_data *ada_inferior_data;
390
391/* A cleanup routine for our inferior data. */
392static void
393ada_inferior_data_cleanup (struct inferior *inf, void *arg)
394{
395 struct ada_inferior_data *data;
396
9a3c8263 397 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
398 if (data != NULL)
399 xfree (data);
400}
401
402/* Return our inferior data for the given inferior (INF).
403
404 This function always returns a valid pointer to an allocated
405 ada_inferior_data structure. If INF's inferior data has not
406 been previously set, this functions creates a new one with all
407 fields set to zero, sets INF's inferior to it, and then returns
408 a pointer to that newly allocated ada_inferior_data. */
409
410static struct ada_inferior_data *
411get_ada_inferior_data (struct inferior *inf)
412{
413 struct ada_inferior_data *data;
414
9a3c8263 415 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
416 if (data == NULL)
417 {
41bf6aca 418 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
419 set_inferior_data (inf, ada_inferior_data, data);
420 }
421
422 return data;
423}
424
425/* Perform all necessary cleanups regarding our module's inferior data
426 that is required after the inferior INF just exited. */
427
428static void
429ada_inferior_exit (struct inferior *inf)
430{
431 ada_inferior_data_cleanup (inf, NULL);
432 set_inferior_data (inf, ada_inferior_data, NULL);
433}
434
ee01b665
JB
435
436 /* program-space-specific data. */
437
438/* This module's per-program-space data. */
439struct ada_pspace_data
440{
441 /* The Ada symbol cache. */
442 struct ada_symbol_cache *sym_cache;
443};
444
445/* Key to our per-program-space data. */
446static const struct program_space_data *ada_pspace_data_handle;
447
448/* Return this module's data for the given program space (PSPACE).
449 If not is found, add a zero'ed one now.
450
451 This function always returns a valid object. */
452
453static struct ada_pspace_data *
454get_ada_pspace_data (struct program_space *pspace)
455{
456 struct ada_pspace_data *data;
457
9a3c8263
SM
458 data = ((struct ada_pspace_data *)
459 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
460 if (data == NULL)
461 {
462 data = XCNEW (struct ada_pspace_data);
463 set_program_space_data (pspace, ada_pspace_data_handle, data);
464 }
465
466 return data;
467}
468
469/* The cleanup callback for this module's per-program-space data. */
470
471static void
472ada_pspace_data_cleanup (struct program_space *pspace, void *data)
473{
9a3c8263 474 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
475
476 if (pspace_data->sym_cache != NULL)
477 ada_free_symbol_cache (pspace_data->sym_cache);
478 xfree (pspace_data);
479}
480
4c4b4cd2
PH
481 /* Utilities */
482
720d1a40 483/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 484 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
485
486 Normally, we really expect a typedef type to only have 1 typedef layer.
487 In other words, we really expect the target type of a typedef type to be
488 a non-typedef type. This is particularly true for Ada units, because
489 the language does not have a typedef vs not-typedef distinction.
490 In that respect, the Ada compiler has been trying to eliminate as many
491 typedef definitions in the debugging information, since they generally
492 do not bring any extra information (we still use typedef under certain
493 circumstances related mostly to the GNAT encoding).
494
495 Unfortunately, we have seen situations where the debugging information
496 generated by the compiler leads to such multiple typedef layers. For
497 instance, consider the following example with stabs:
498
499 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
500 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
501
502 This is an error in the debugging information which causes type
503 pck__float_array___XUP to be defined twice, and the second time,
504 it is defined as a typedef of a typedef.
505
506 This is on the fringe of legality as far as debugging information is
507 concerned, and certainly unexpected. But it is easy to handle these
508 situations correctly, so we can afford to be lenient in this case. */
509
510static struct type *
511ada_typedef_target_type (struct type *type)
512{
513 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
514 type = TYPE_TARGET_TYPE (type);
515 return type;
516}
517
41d27058
JB
518/* Given DECODED_NAME a string holding a symbol name in its
519 decoded form (ie using the Ada dotted notation), returns
520 its unqualified name. */
521
522static const char *
523ada_unqualified_name (const char *decoded_name)
524{
2b0f535a
JB
525 const char *result;
526
527 /* If the decoded name starts with '<', it means that the encoded
528 name does not follow standard naming conventions, and thus that
529 it is not your typical Ada symbol name. Trying to unqualify it
530 is therefore pointless and possibly erroneous. */
531 if (decoded_name[0] == '<')
532 return decoded_name;
533
534 result = strrchr (decoded_name, '.');
41d27058
JB
535 if (result != NULL)
536 result++; /* Skip the dot... */
537 else
538 result = decoded_name;
539
540 return result;
541}
542
39e7af3e 543/* Return a string starting with '<', followed by STR, and '>'. */
41d27058 544
39e7af3e 545static std::string
41d27058
JB
546add_angle_brackets (const char *str)
547{
39e7af3e 548 return string_printf ("<%s>", str);
41d27058 549}
96d887e8 550
67cb5b2d 551static const char *
4c4b4cd2
PH
552ada_get_gdb_completer_word_break_characters (void)
553{
554 return ada_completer_word_break_characters;
555}
556
e79af960
JB
557/* Print an array element index using the Ada syntax. */
558
559static void
560ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 561 const struct value_print_options *options)
e79af960 562{
79a45b7d 563 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
564 fprintf_filtered (stream, " => ");
565}
566
e2b7af72
JB
567/* la_watch_location_expression for Ada. */
568
569gdb::unique_xmalloc_ptr<char>
570ada_watch_location_expression (struct type *type, CORE_ADDR addr)
571{
572 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
573 std::string name = type_to_string (type);
574 return gdb::unique_xmalloc_ptr<char>
575 (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
576}
577
f27cf670 578/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 579 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 580 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 581
f27cf670
AS
582void *
583grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 584{
d2e4a39e
AS
585 if (*size < min_size)
586 {
587 *size *= 2;
588 if (*size < min_size)
4c4b4cd2 589 *size = min_size;
f27cf670 590 vect = xrealloc (vect, *size * element_size);
d2e4a39e 591 }
f27cf670 592 return vect;
14f9c5c9
AS
593}
594
595/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 596 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
597
598static int
ebf56fd3 599field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
600{
601 int len = strlen (target);
5b4ee69b 602
d2e4a39e 603 return
4c4b4cd2
PH
604 (strncmp (field_name, target, len) == 0
605 && (field_name[len] == '\0'
61012eef 606 || (startswith (field_name + len, "___")
76a01679
JB
607 && strcmp (field_name + strlen (field_name) - 6,
608 "___XVN") != 0)));
14f9c5c9
AS
609}
610
611
872c8b51
JB
612/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
613 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
614 and return its index. This function also handles fields whose name
615 have ___ suffixes because the compiler sometimes alters their name
616 by adding such a suffix to represent fields with certain constraints.
617 If the field could not be found, return a negative number if
618 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
619
620int
621ada_get_field_index (const struct type *type, const char *field_name,
622 int maybe_missing)
623{
624 int fieldno;
872c8b51
JB
625 struct type *struct_type = check_typedef ((struct type *) type);
626
627 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
628 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
629 return fieldno;
630
631 if (!maybe_missing)
323e0a4a 632 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 633 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
634
635 return -1;
636}
637
638/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
639
640int
d2e4a39e 641ada_name_prefix_len (const char *name)
14f9c5c9
AS
642{
643 if (name == NULL)
644 return 0;
d2e4a39e 645 else
14f9c5c9 646 {
d2e4a39e 647 const char *p = strstr (name, "___");
5b4ee69b 648
14f9c5c9 649 if (p == NULL)
4c4b4cd2 650 return strlen (name);
14f9c5c9 651 else
4c4b4cd2 652 return p - name;
14f9c5c9
AS
653 }
654}
655
4c4b4cd2
PH
656/* Return non-zero if SUFFIX is a suffix of STR.
657 Return zero if STR is null. */
658
14f9c5c9 659static int
d2e4a39e 660is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
661{
662 int len1, len2;
5b4ee69b 663
14f9c5c9
AS
664 if (str == NULL)
665 return 0;
666 len1 = strlen (str);
667 len2 = strlen (suffix);
4c4b4cd2 668 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
669}
670
4c4b4cd2
PH
671/* The contents of value VAL, treated as a value of type TYPE. The
672 result is an lval in memory if VAL is. */
14f9c5c9 673
d2e4a39e 674static struct value *
4c4b4cd2 675coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 676{
61ee279c 677 type = ada_check_typedef (type);
df407dfe 678 if (value_type (val) == type)
4c4b4cd2 679 return val;
d2e4a39e 680 else
14f9c5c9 681 {
4c4b4cd2
PH
682 struct value *result;
683
684 /* Make sure that the object size is not unreasonable before
685 trying to allocate some memory for it. */
c1b5a1a6 686 ada_ensure_varsize_limit (type);
4c4b4cd2 687
41e8491f
JK
688 if (value_lazy (val)
689 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
690 result = allocate_value_lazy (type);
691 else
692 {
693 result = allocate_value (type);
9a0dc9e3 694 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 695 }
74bcbdf3 696 set_value_component_location (result, val);
9bbda503
AC
697 set_value_bitsize (result, value_bitsize (val));
698 set_value_bitpos (result, value_bitpos (val));
42ae5230 699 set_value_address (result, value_address (val));
14f9c5c9
AS
700 return result;
701 }
702}
703
fc1a4b47
AC
704static const gdb_byte *
705cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
706{
707 if (valaddr == NULL)
708 return NULL;
709 else
710 return valaddr + offset;
711}
712
713static CORE_ADDR
ebf56fd3 714cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
715{
716 if (address == 0)
717 return 0;
d2e4a39e 718 else
14f9c5c9
AS
719 return address + offset;
720}
721
4c4b4cd2
PH
722/* Issue a warning (as for the definition of warning in utils.c, but
723 with exactly one argument rather than ...), unless the limit on the
724 number of warnings has passed during the evaluation of the current
725 expression. */
a2249542 726
77109804
AC
727/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
728 provided by "complaint". */
a0b31db1 729static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 730
14f9c5c9 731static void
a2249542 732lim_warning (const char *format, ...)
14f9c5c9 733{
a2249542 734 va_list args;
a2249542 735
5b4ee69b 736 va_start (args, format);
4c4b4cd2
PH
737 warnings_issued += 1;
738 if (warnings_issued <= warning_limit)
a2249542
MK
739 vwarning (format, args);
740
741 va_end (args);
4c4b4cd2
PH
742}
743
714e53ab
PH
744/* Issue an error if the size of an object of type T is unreasonable,
745 i.e. if it would be a bad idea to allocate a value of this type in
746 GDB. */
747
c1b5a1a6
JB
748void
749ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
750{
751 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 752 error (_("object size is larger than varsize-limit"));
714e53ab
PH
753}
754
0963b4bd 755/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 756static LONGEST
c3e5cd34 757max_of_size (int size)
4c4b4cd2 758{
76a01679 759 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 760
76a01679 761 return top_bit | (top_bit - 1);
4c4b4cd2
PH
762}
763
0963b4bd 764/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 765static LONGEST
c3e5cd34 766min_of_size (int size)
4c4b4cd2 767{
c3e5cd34 768 return -max_of_size (size) - 1;
4c4b4cd2
PH
769}
770
0963b4bd 771/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 772static ULONGEST
c3e5cd34 773umax_of_size (int size)
4c4b4cd2 774{
76a01679 775 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 776
76a01679 777 return top_bit | (top_bit - 1);
4c4b4cd2
PH
778}
779
0963b4bd 780/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
781static LONGEST
782max_of_type (struct type *t)
4c4b4cd2 783{
c3e5cd34
PH
784 if (TYPE_UNSIGNED (t))
785 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
786 else
787 return max_of_size (TYPE_LENGTH (t));
788}
789
0963b4bd 790/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
791static LONGEST
792min_of_type (struct type *t)
793{
794 if (TYPE_UNSIGNED (t))
795 return 0;
796 else
797 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
798}
799
800/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
801LONGEST
802ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 803{
c3345124 804 type = resolve_dynamic_type (type, NULL, 0);
76a01679 805 switch (TYPE_CODE (type))
4c4b4cd2
PH
806 {
807 case TYPE_CODE_RANGE:
690cc4eb 808 return TYPE_HIGH_BOUND (type);
4c4b4cd2 809 case TYPE_CODE_ENUM:
14e75d8e 810 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
811 case TYPE_CODE_BOOL:
812 return 1;
813 case TYPE_CODE_CHAR:
76a01679 814 case TYPE_CODE_INT:
690cc4eb 815 return max_of_type (type);
4c4b4cd2 816 default:
43bbcdc2 817 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
818 }
819}
820
14e75d8e 821/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
822LONGEST
823ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 824{
c3345124 825 type = resolve_dynamic_type (type, NULL, 0);
76a01679 826 switch (TYPE_CODE (type))
4c4b4cd2
PH
827 {
828 case TYPE_CODE_RANGE:
690cc4eb 829 return TYPE_LOW_BOUND (type);
4c4b4cd2 830 case TYPE_CODE_ENUM:
14e75d8e 831 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
832 case TYPE_CODE_BOOL:
833 return 0;
834 case TYPE_CODE_CHAR:
76a01679 835 case TYPE_CODE_INT:
690cc4eb 836 return min_of_type (type);
4c4b4cd2 837 default:
43bbcdc2 838 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
839 }
840}
841
842/* The identity on non-range types. For range types, the underlying
76a01679 843 non-range scalar type. */
4c4b4cd2
PH
844
845static struct type *
18af8284 846get_base_type (struct type *type)
4c4b4cd2
PH
847{
848 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
849 {
76a01679
JB
850 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
851 return type;
4c4b4cd2
PH
852 type = TYPE_TARGET_TYPE (type);
853 }
854 return type;
14f9c5c9 855}
41246937
JB
856
857/* Return a decoded version of the given VALUE. This means returning
858 a value whose type is obtained by applying all the GNAT-specific
859 encondings, making the resulting type a static but standard description
860 of the initial type. */
861
862struct value *
863ada_get_decoded_value (struct value *value)
864{
865 struct type *type = ada_check_typedef (value_type (value));
866
867 if (ada_is_array_descriptor_type (type)
868 || (ada_is_constrained_packed_array_type (type)
869 && TYPE_CODE (type) != TYPE_CODE_PTR))
870 {
871 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
872 value = ada_coerce_to_simple_array_ptr (value);
873 else
874 value = ada_coerce_to_simple_array (value);
875 }
876 else
877 value = ada_to_fixed_value (value);
878
879 return value;
880}
881
882/* Same as ada_get_decoded_value, but with the given TYPE.
883 Because there is no associated actual value for this type,
884 the resulting type might be a best-effort approximation in
885 the case of dynamic types. */
886
887struct type *
888ada_get_decoded_type (struct type *type)
889{
890 type = to_static_fixed_type (type);
891 if (ada_is_constrained_packed_array_type (type))
892 type = ada_coerce_to_simple_array_type (type);
893 return type;
894}
895
4c4b4cd2 896\f
76a01679 897
4c4b4cd2 898 /* Language Selection */
14f9c5c9
AS
899
900/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 901 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 902
14f9c5c9 903enum language
ccefe4c4 904ada_update_initial_language (enum language lang)
14f9c5c9 905{
d2e4a39e 906 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 907 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 908 return language_ada;
14f9c5c9
AS
909
910 return lang;
911}
96d887e8
PH
912
913/* If the main procedure is written in Ada, then return its name.
914 The result is good until the next call. Return NULL if the main
915 procedure doesn't appear to be in Ada. */
916
917char *
918ada_main_name (void)
919{
3b7344d5 920 struct bound_minimal_symbol msym;
e83e4e24 921 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 922
96d887e8
PH
923 /* For Ada, the name of the main procedure is stored in a specific
924 string constant, generated by the binder. Look for that symbol,
925 extract its address, and then read that string. If we didn't find
926 that string, then most probably the main procedure is not written
927 in Ada. */
928 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
929
3b7344d5 930 if (msym.minsym != NULL)
96d887e8 931 {
f9bc20b9
JB
932 CORE_ADDR main_program_name_addr;
933 int err_code;
934
77e371c0 935 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 936 if (main_program_name_addr == 0)
323e0a4a 937 error (_("Invalid address for Ada main program name."));
96d887e8 938
f9bc20b9
JB
939 target_read_string (main_program_name_addr, &main_program_name,
940 1024, &err_code);
941
942 if (err_code != 0)
943 return NULL;
e83e4e24 944 return main_program_name.get ();
96d887e8
PH
945 }
946
947 /* The main procedure doesn't seem to be in Ada. */
948 return NULL;
949}
14f9c5c9 950\f
4c4b4cd2 951 /* Symbols */
d2e4a39e 952
4c4b4cd2
PH
953/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
954 of NULLs. */
14f9c5c9 955
d2e4a39e
AS
956const struct ada_opname_map ada_opname_table[] = {
957 {"Oadd", "\"+\"", BINOP_ADD},
958 {"Osubtract", "\"-\"", BINOP_SUB},
959 {"Omultiply", "\"*\"", BINOP_MUL},
960 {"Odivide", "\"/\"", BINOP_DIV},
961 {"Omod", "\"mod\"", BINOP_MOD},
962 {"Orem", "\"rem\"", BINOP_REM},
963 {"Oexpon", "\"**\"", BINOP_EXP},
964 {"Olt", "\"<\"", BINOP_LESS},
965 {"Ole", "\"<=\"", BINOP_LEQ},
966 {"Ogt", "\">\"", BINOP_GTR},
967 {"Oge", "\">=\"", BINOP_GEQ},
968 {"Oeq", "\"=\"", BINOP_EQUAL},
969 {"One", "\"/=\"", BINOP_NOTEQUAL},
970 {"Oand", "\"and\"", BINOP_BITWISE_AND},
971 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
972 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
973 {"Oconcat", "\"&\"", BINOP_CONCAT},
974 {"Oabs", "\"abs\"", UNOP_ABS},
975 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
976 {"Oadd", "\"+\"", UNOP_PLUS},
977 {"Osubtract", "\"-\"", UNOP_NEG},
978 {NULL, NULL}
14f9c5c9
AS
979};
980
b5ec771e
PA
981/* The "encoded" form of DECODED, according to GNAT conventions. The
982 result is valid until the next call to ada_encode. If
983 THROW_ERRORS, throw an error if invalid operator name is found.
984 Otherwise, return NULL in that case. */
4c4b4cd2 985
b5ec771e
PA
986static char *
987ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 988{
4c4b4cd2
PH
989 static char *encoding_buffer = NULL;
990 static size_t encoding_buffer_size = 0;
d2e4a39e 991 const char *p;
14f9c5c9 992 int k;
d2e4a39e 993
4c4b4cd2 994 if (decoded == NULL)
14f9c5c9
AS
995 return NULL;
996
4c4b4cd2
PH
997 GROW_VECT (encoding_buffer, encoding_buffer_size,
998 2 * strlen (decoded) + 10);
14f9c5c9
AS
999
1000 k = 0;
4c4b4cd2 1001 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 1002 {
cdc7bb92 1003 if (*p == '.')
4c4b4cd2
PH
1004 {
1005 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1006 k += 2;
1007 }
14f9c5c9 1008 else if (*p == '"')
4c4b4cd2
PH
1009 {
1010 const struct ada_opname_map *mapping;
1011
1012 for (mapping = ada_opname_table;
1265e4aa 1013 mapping->encoded != NULL
61012eef 1014 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1015 ;
1016 if (mapping->encoded == NULL)
b5ec771e
PA
1017 {
1018 if (throw_errors)
1019 error (_("invalid Ada operator name: %s"), p);
1020 else
1021 return NULL;
1022 }
4c4b4cd2
PH
1023 strcpy (encoding_buffer + k, mapping->encoded);
1024 k += strlen (mapping->encoded);
1025 break;
1026 }
d2e4a39e 1027 else
4c4b4cd2
PH
1028 {
1029 encoding_buffer[k] = *p;
1030 k += 1;
1031 }
14f9c5c9
AS
1032 }
1033
4c4b4cd2
PH
1034 encoding_buffer[k] = '\0';
1035 return encoding_buffer;
14f9c5c9
AS
1036}
1037
b5ec771e
PA
1038/* The "encoded" form of DECODED, according to GNAT conventions.
1039 The result is valid until the next call to ada_encode. */
1040
1041char *
1042ada_encode (const char *decoded)
1043{
1044 return ada_encode_1 (decoded, true);
1045}
1046
14f9c5c9 1047/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1048 quotes, unfolded, but with the quotes stripped away. Result good
1049 to next call. */
1050
d2e4a39e
AS
1051char *
1052ada_fold_name (const char *name)
14f9c5c9 1053{
d2e4a39e 1054 static char *fold_buffer = NULL;
14f9c5c9
AS
1055 static size_t fold_buffer_size = 0;
1056
1057 int len = strlen (name);
d2e4a39e 1058 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1059
1060 if (name[0] == '\'')
1061 {
d2e4a39e
AS
1062 strncpy (fold_buffer, name + 1, len - 2);
1063 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1064 }
1065 else
1066 {
1067 int i;
5b4ee69b 1068
14f9c5c9 1069 for (i = 0; i <= len; i += 1)
4c4b4cd2 1070 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1071 }
1072
1073 return fold_buffer;
1074}
1075
529cad9c
PH
1076/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1077
1078static int
1079is_lower_alphanum (const char c)
1080{
1081 return (isdigit (c) || (isalpha (c) && islower (c)));
1082}
1083
c90092fe
JB
1084/* ENCODED is the linkage name of a symbol and LEN contains its length.
1085 This function saves in LEN the length of that same symbol name but
1086 without either of these suffixes:
29480c32
JB
1087 . .{DIGIT}+
1088 . ${DIGIT}+
1089 . ___{DIGIT}+
1090 . __{DIGIT}+.
c90092fe 1091
29480c32
JB
1092 These are suffixes introduced by the compiler for entities such as
1093 nested subprogram for instance, in order to avoid name clashes.
1094 They do not serve any purpose for the debugger. */
1095
1096static void
1097ada_remove_trailing_digits (const char *encoded, int *len)
1098{
1099 if (*len > 1 && isdigit (encoded[*len - 1]))
1100 {
1101 int i = *len - 2;
5b4ee69b 1102
29480c32
JB
1103 while (i > 0 && isdigit (encoded[i]))
1104 i--;
1105 if (i >= 0 && encoded[i] == '.')
1106 *len = i;
1107 else if (i >= 0 && encoded[i] == '$')
1108 *len = i;
61012eef 1109 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1110 *len = i - 2;
61012eef 1111 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1112 *len = i - 1;
1113 }
1114}
1115
1116/* Remove the suffix introduced by the compiler for protected object
1117 subprograms. */
1118
1119static void
1120ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1121{
1122 /* Remove trailing N. */
1123
1124 /* Protected entry subprograms are broken into two
1125 separate subprograms: The first one is unprotected, and has
1126 a 'N' suffix; the second is the protected version, and has
0963b4bd 1127 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1128 the protection. Since the P subprograms are internally generated,
1129 we leave these names undecoded, giving the user a clue that this
1130 entity is internal. */
1131
1132 if (*len > 1
1133 && encoded[*len - 1] == 'N'
1134 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1135 *len = *len - 1;
1136}
1137
69fadcdf
JB
1138/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1139
1140static void
1141ada_remove_Xbn_suffix (const char *encoded, int *len)
1142{
1143 int i = *len - 1;
1144
1145 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1146 i--;
1147
1148 if (encoded[i] != 'X')
1149 return;
1150
1151 if (i == 0)
1152 return;
1153
1154 if (isalnum (encoded[i-1]))
1155 *len = i;
1156}
1157
29480c32
JB
1158/* If ENCODED follows the GNAT entity encoding conventions, then return
1159 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1160 replaced by ENCODED.
14f9c5c9 1161
4c4b4cd2 1162 The resulting string is valid until the next call of ada_decode.
29480c32 1163 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1164 is returned. */
1165
1166const char *
1167ada_decode (const char *encoded)
14f9c5c9
AS
1168{
1169 int i, j;
1170 int len0;
d2e4a39e 1171 const char *p;
4c4b4cd2 1172 char *decoded;
14f9c5c9 1173 int at_start_name;
4c4b4cd2
PH
1174 static char *decoding_buffer = NULL;
1175 static size_t decoding_buffer_size = 0;
d2e4a39e 1176
0d81f350
JG
1177 /* With function descriptors on PPC64, the value of a symbol named
1178 ".FN", if it exists, is the entry point of the function "FN". */
1179 if (encoded[0] == '.')
1180 encoded += 1;
1181
29480c32
JB
1182 /* The name of the Ada main procedure starts with "_ada_".
1183 This prefix is not part of the decoded name, so skip this part
1184 if we see this prefix. */
61012eef 1185 if (startswith (encoded, "_ada_"))
4c4b4cd2 1186 encoded += 5;
14f9c5c9 1187
29480c32
JB
1188 /* If the name starts with '_', then it is not a properly encoded
1189 name, so do not attempt to decode it. Similarly, if the name
1190 starts with '<', the name should not be decoded. */
4c4b4cd2 1191 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1192 goto Suppress;
1193
4c4b4cd2 1194 len0 = strlen (encoded);
4c4b4cd2 1195
29480c32
JB
1196 ada_remove_trailing_digits (encoded, &len0);
1197 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1198
4c4b4cd2
PH
1199 /* Remove the ___X.* suffix if present. Do not forget to verify that
1200 the suffix is located before the current "end" of ENCODED. We want
1201 to avoid re-matching parts of ENCODED that have previously been
1202 marked as discarded (by decrementing LEN0). */
1203 p = strstr (encoded, "___");
1204 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1205 {
1206 if (p[3] == 'X')
4c4b4cd2 1207 len0 = p - encoded;
14f9c5c9 1208 else
4c4b4cd2 1209 goto Suppress;
14f9c5c9 1210 }
4c4b4cd2 1211
29480c32
JB
1212 /* Remove any trailing TKB suffix. It tells us that this symbol
1213 is for the body of a task, but that information does not actually
1214 appear in the decoded name. */
1215
61012eef 1216 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1217 len0 -= 3;
76a01679 1218
a10967fa
JB
1219 /* Remove any trailing TB suffix. The TB suffix is slightly different
1220 from the TKB suffix because it is used for non-anonymous task
1221 bodies. */
1222
61012eef 1223 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1224 len0 -= 2;
1225
29480c32
JB
1226 /* Remove trailing "B" suffixes. */
1227 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1228
61012eef 1229 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1230 len0 -= 1;
1231
4c4b4cd2 1232 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1233
4c4b4cd2
PH
1234 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1235 decoded = decoding_buffer;
14f9c5c9 1236
29480c32
JB
1237 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1238
4c4b4cd2 1239 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1240 {
4c4b4cd2
PH
1241 i = len0 - 2;
1242 while ((i >= 0 && isdigit (encoded[i]))
1243 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1244 i -= 1;
1245 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1246 len0 = i - 1;
1247 else if (encoded[i] == '$')
1248 len0 = i;
d2e4a39e 1249 }
14f9c5c9 1250
29480c32
JB
1251 /* The first few characters that are not alphabetic are not part
1252 of any encoding we use, so we can copy them over verbatim. */
1253
4c4b4cd2
PH
1254 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1255 decoded[j] = encoded[i];
14f9c5c9
AS
1256
1257 at_start_name = 1;
1258 while (i < len0)
1259 {
29480c32 1260 /* Is this a symbol function? */
4c4b4cd2
PH
1261 if (at_start_name && encoded[i] == 'O')
1262 {
1263 int k;
5b4ee69b 1264
4c4b4cd2
PH
1265 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1266 {
1267 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1268 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1269 op_len - 1) == 0)
1270 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1271 {
1272 strcpy (decoded + j, ada_opname_table[k].decoded);
1273 at_start_name = 0;
1274 i += op_len;
1275 j += strlen (ada_opname_table[k].decoded);
1276 break;
1277 }
1278 }
1279 if (ada_opname_table[k].encoded != NULL)
1280 continue;
1281 }
14f9c5c9
AS
1282 at_start_name = 0;
1283
529cad9c
PH
1284 /* Replace "TK__" with "__", which will eventually be translated
1285 into "." (just below). */
1286
61012eef 1287 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1288 i += 2;
529cad9c 1289
29480c32
JB
1290 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1291 be translated into "." (just below). These are internal names
1292 generated for anonymous blocks inside which our symbol is nested. */
1293
1294 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1295 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1296 && isdigit (encoded [i+4]))
1297 {
1298 int k = i + 5;
1299
1300 while (k < len0 && isdigit (encoded[k]))
1301 k++; /* Skip any extra digit. */
1302
1303 /* Double-check that the "__B_{DIGITS}+" sequence we found
1304 is indeed followed by "__". */
1305 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1306 i = k;
1307 }
1308
529cad9c
PH
1309 /* Remove _E{DIGITS}+[sb] */
1310
1311 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1312 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1313 one implements the actual entry code, and has a suffix following
1314 the convention above; the second one implements the barrier and
1315 uses the same convention as above, except that the 'E' is replaced
1316 by a 'B'.
1317
1318 Just as above, we do not decode the name of barrier functions
1319 to give the user a clue that the code he is debugging has been
1320 internally generated. */
1321
1322 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1323 && isdigit (encoded[i+2]))
1324 {
1325 int k = i + 3;
1326
1327 while (k < len0 && isdigit (encoded[k]))
1328 k++;
1329
1330 if (k < len0
1331 && (encoded[k] == 'b' || encoded[k] == 's'))
1332 {
1333 k++;
1334 /* Just as an extra precaution, make sure that if this
1335 suffix is followed by anything else, it is a '_'.
1336 Otherwise, we matched this sequence by accident. */
1337 if (k == len0
1338 || (k < len0 && encoded[k] == '_'))
1339 i = k;
1340 }
1341 }
1342
1343 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1344 the GNAT front-end in protected object subprograms. */
1345
1346 if (i < len0 + 3
1347 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1348 {
1349 /* Backtrack a bit up until we reach either the begining of
1350 the encoded name, or "__". Make sure that we only find
1351 digits or lowercase characters. */
1352 const char *ptr = encoded + i - 1;
1353
1354 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1355 ptr--;
1356 if (ptr < encoded
1357 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1358 i++;
1359 }
1360
4c4b4cd2
PH
1361 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1362 {
29480c32
JB
1363 /* This is a X[bn]* sequence not separated from the previous
1364 part of the name with a non-alpha-numeric character (in other
1365 words, immediately following an alpha-numeric character), then
1366 verify that it is placed at the end of the encoded name. If
1367 not, then the encoding is not valid and we should abort the
1368 decoding. Otherwise, just skip it, it is used in body-nested
1369 package names. */
4c4b4cd2
PH
1370 do
1371 i += 1;
1372 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1373 if (i < len0)
1374 goto Suppress;
1375 }
cdc7bb92 1376 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1377 {
29480c32 1378 /* Replace '__' by '.'. */
4c4b4cd2
PH
1379 decoded[j] = '.';
1380 at_start_name = 1;
1381 i += 2;
1382 j += 1;
1383 }
14f9c5c9 1384 else
4c4b4cd2 1385 {
29480c32
JB
1386 /* It's a character part of the decoded name, so just copy it
1387 over. */
4c4b4cd2
PH
1388 decoded[j] = encoded[i];
1389 i += 1;
1390 j += 1;
1391 }
14f9c5c9 1392 }
4c4b4cd2 1393 decoded[j] = '\000';
14f9c5c9 1394
29480c32
JB
1395 /* Decoded names should never contain any uppercase character.
1396 Double-check this, and abort the decoding if we find one. */
1397
4c4b4cd2
PH
1398 for (i = 0; decoded[i] != '\0'; i += 1)
1399 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1400 goto Suppress;
1401
4c4b4cd2
PH
1402 if (strcmp (decoded, encoded) == 0)
1403 return encoded;
1404 else
1405 return decoded;
14f9c5c9
AS
1406
1407Suppress:
4c4b4cd2
PH
1408 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1409 decoded = decoding_buffer;
1410 if (encoded[0] == '<')
1411 strcpy (decoded, encoded);
14f9c5c9 1412 else
88c15c34 1413 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1414 return decoded;
1415
1416}
1417
1418/* Table for keeping permanent unique copies of decoded names. Once
1419 allocated, names in this table are never released. While this is a
1420 storage leak, it should not be significant unless there are massive
1421 changes in the set of decoded names in successive versions of a
1422 symbol table loaded during a single session. */
1423static struct htab *decoded_names_store;
1424
1425/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1426 in the language-specific part of GSYMBOL, if it has not been
1427 previously computed. Tries to save the decoded name in the same
1428 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1429 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1430 GSYMBOL).
4c4b4cd2
PH
1431 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1432 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1433 when a decoded name is cached in it. */
4c4b4cd2 1434
45e6c716 1435const char *
f85f34ed 1436ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1437{
f85f34ed
TT
1438 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1439 const char **resultp =
615b3f62 1440 &gsymbol->language_specific.demangled_name;
5b4ee69b 1441
f85f34ed 1442 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1443 {
1444 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1445 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1446
f85f34ed 1447 gsymbol->ada_mangled = 1;
5b4ee69b 1448
f85f34ed 1449 if (obstack != NULL)
224c3ddb
SM
1450 *resultp
1451 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1452 else
76a01679 1453 {
f85f34ed
TT
1454 /* Sometimes, we can't find a corresponding objfile, in
1455 which case, we put the result on the heap. Since we only
1456 decode when needed, we hope this usually does not cause a
1457 significant memory leak (FIXME). */
1458
76a01679
JB
1459 char **slot = (char **) htab_find_slot (decoded_names_store,
1460 decoded, INSERT);
5b4ee69b 1461
76a01679
JB
1462 if (*slot == NULL)
1463 *slot = xstrdup (decoded);
1464 *resultp = *slot;
1465 }
4c4b4cd2 1466 }
14f9c5c9 1467
4c4b4cd2
PH
1468 return *resultp;
1469}
76a01679 1470
2c0b251b 1471static char *
76a01679 1472ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1473{
1474 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1475}
1476
8b302db8
TT
1477/* Implement la_sniff_from_mangled_name for Ada. */
1478
1479static int
1480ada_sniff_from_mangled_name (const char *mangled, char **out)
1481{
1482 const char *demangled = ada_decode (mangled);
1483
1484 *out = NULL;
1485
1486 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1487 {
1488 /* Set the gsymbol language to Ada, but still return 0.
1489 Two reasons for that:
1490
1491 1. For Ada, we prefer computing the symbol's decoded name
1492 on the fly rather than pre-compute it, in order to save
1493 memory (Ada projects are typically very large).
1494
1495 2. There are some areas in the definition of the GNAT
1496 encoding where, with a bit of bad luck, we might be able
1497 to decode a non-Ada symbol, generating an incorrect
1498 demangled name (Eg: names ending with "TB" for instance
1499 are identified as task bodies and so stripped from
1500 the decoded name returned).
1501
1502 Returning 1, here, but not setting *DEMANGLED, helps us get a
1503 little bit of the best of both worlds. Because we're last,
1504 we should not affect any of the other languages that were
1505 able to demangle the symbol before us; we get to correctly
1506 tag Ada symbols as such; and even if we incorrectly tagged a
1507 non-Ada symbol, which should be rare, any routing through the
1508 Ada language should be transparent (Ada tries to behave much
1509 like C/C++ with non-Ada symbols). */
1510 return 1;
1511 }
1512
1513 return 0;
1514}
1515
14f9c5c9 1516\f
d2e4a39e 1517
4c4b4cd2 1518 /* Arrays */
14f9c5c9 1519
28c85d6c
JB
1520/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1521 generated by the GNAT compiler to describe the index type used
1522 for each dimension of an array, check whether it follows the latest
1523 known encoding. If not, fix it up to conform to the latest encoding.
1524 Otherwise, do nothing. This function also does nothing if
1525 INDEX_DESC_TYPE is NULL.
1526
1527 The GNAT encoding used to describle the array index type evolved a bit.
1528 Initially, the information would be provided through the name of each
1529 field of the structure type only, while the type of these fields was
1530 described as unspecified and irrelevant. The debugger was then expected
1531 to perform a global type lookup using the name of that field in order
1532 to get access to the full index type description. Because these global
1533 lookups can be very expensive, the encoding was later enhanced to make
1534 the global lookup unnecessary by defining the field type as being
1535 the full index type description.
1536
1537 The purpose of this routine is to allow us to support older versions
1538 of the compiler by detecting the use of the older encoding, and by
1539 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1540 we essentially replace each field's meaningless type by the associated
1541 index subtype). */
1542
1543void
1544ada_fixup_array_indexes_type (struct type *index_desc_type)
1545{
1546 int i;
1547
1548 if (index_desc_type == NULL)
1549 return;
1550 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1551
1552 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1553 to check one field only, no need to check them all). If not, return
1554 now.
1555
1556 If our INDEX_DESC_TYPE was generated using the older encoding,
1557 the field type should be a meaningless integer type whose name
1558 is not equal to the field name. */
1559 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1560 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1561 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1562 return;
1563
1564 /* Fixup each field of INDEX_DESC_TYPE. */
1565 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1566 {
0d5cff50 1567 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1568 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1569
1570 if (raw_type)
1571 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1572 }
1573}
1574
4c4b4cd2 1575/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1576
a121b7c1 1577static const char *bound_name[] = {
d2e4a39e 1578 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1579 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1580};
1581
1582/* Maximum number of array dimensions we are prepared to handle. */
1583
4c4b4cd2 1584#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1585
14f9c5c9 1586
4c4b4cd2
PH
1587/* The desc_* routines return primitive portions of array descriptors
1588 (fat pointers). */
14f9c5c9
AS
1589
1590/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1591 level of indirection, if needed. */
1592
d2e4a39e
AS
1593static struct type *
1594desc_base_type (struct type *type)
14f9c5c9
AS
1595{
1596 if (type == NULL)
1597 return NULL;
61ee279c 1598 type = ada_check_typedef (type);
720d1a40
JB
1599 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1600 type = ada_typedef_target_type (type);
1601
1265e4aa
JB
1602 if (type != NULL
1603 && (TYPE_CODE (type) == TYPE_CODE_PTR
1604 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1605 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1606 else
1607 return type;
1608}
1609
4c4b4cd2
PH
1610/* True iff TYPE indicates a "thin" array pointer type. */
1611
14f9c5c9 1612static int
d2e4a39e 1613is_thin_pntr (struct type *type)
14f9c5c9 1614{
d2e4a39e 1615 return
14f9c5c9
AS
1616 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1617 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1618}
1619
4c4b4cd2
PH
1620/* The descriptor type for thin pointer type TYPE. */
1621
d2e4a39e
AS
1622static struct type *
1623thin_descriptor_type (struct type *type)
14f9c5c9 1624{
d2e4a39e 1625 struct type *base_type = desc_base_type (type);
5b4ee69b 1626
14f9c5c9
AS
1627 if (base_type == NULL)
1628 return NULL;
1629 if (is_suffix (ada_type_name (base_type), "___XVE"))
1630 return base_type;
d2e4a39e 1631 else
14f9c5c9 1632 {
d2e4a39e 1633 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1634
14f9c5c9 1635 if (alt_type == NULL)
4c4b4cd2 1636 return base_type;
14f9c5c9 1637 else
4c4b4cd2 1638 return alt_type;
14f9c5c9
AS
1639 }
1640}
1641
4c4b4cd2
PH
1642/* A pointer to the array data for thin-pointer value VAL. */
1643
d2e4a39e
AS
1644static struct value *
1645thin_data_pntr (struct value *val)
14f9c5c9 1646{
828292f2 1647 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1648 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1649
556bdfd4
UW
1650 data_type = lookup_pointer_type (data_type);
1651
14f9c5c9 1652 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1653 return value_cast (data_type, value_copy (val));
d2e4a39e 1654 else
42ae5230 1655 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1656}
1657
4c4b4cd2
PH
1658/* True iff TYPE indicates a "thick" array pointer type. */
1659
14f9c5c9 1660static int
d2e4a39e 1661is_thick_pntr (struct type *type)
14f9c5c9
AS
1662{
1663 type = desc_base_type (type);
1664 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1665 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1666}
1667
4c4b4cd2
PH
1668/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1669 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1670
d2e4a39e
AS
1671static struct type *
1672desc_bounds_type (struct type *type)
14f9c5c9 1673{
d2e4a39e 1674 struct type *r;
14f9c5c9
AS
1675
1676 type = desc_base_type (type);
1677
1678 if (type == NULL)
1679 return NULL;
1680 else if (is_thin_pntr (type))
1681 {
1682 type = thin_descriptor_type (type);
1683 if (type == NULL)
4c4b4cd2 1684 return NULL;
14f9c5c9
AS
1685 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1686 if (r != NULL)
61ee279c 1687 return ada_check_typedef (r);
14f9c5c9
AS
1688 }
1689 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1690 {
1691 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1692 if (r != NULL)
61ee279c 1693 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1694 }
1695 return NULL;
1696}
1697
1698/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1699 one, a pointer to its bounds data. Otherwise NULL. */
1700
d2e4a39e
AS
1701static struct value *
1702desc_bounds (struct value *arr)
14f9c5c9 1703{
df407dfe 1704 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1705
d2e4a39e 1706 if (is_thin_pntr (type))
14f9c5c9 1707 {
d2e4a39e 1708 struct type *bounds_type =
4c4b4cd2 1709 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1710 LONGEST addr;
1711
4cdfadb1 1712 if (bounds_type == NULL)
323e0a4a 1713 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1714
1715 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1716 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1717 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1718 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1719 addr = value_as_long (arr);
d2e4a39e 1720 else
42ae5230 1721 addr = value_address (arr);
14f9c5c9 1722
d2e4a39e 1723 return
4c4b4cd2
PH
1724 value_from_longest (lookup_pointer_type (bounds_type),
1725 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1726 }
1727
1728 else if (is_thick_pntr (type))
05e522ef
JB
1729 {
1730 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1731 _("Bad GNAT array descriptor"));
1732 struct type *p_bounds_type = value_type (p_bounds);
1733
1734 if (p_bounds_type
1735 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1736 {
1737 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1738
1739 if (TYPE_STUB (target_type))
1740 p_bounds = value_cast (lookup_pointer_type
1741 (ada_check_typedef (target_type)),
1742 p_bounds);
1743 }
1744 else
1745 error (_("Bad GNAT array descriptor"));
1746
1747 return p_bounds;
1748 }
14f9c5c9
AS
1749 else
1750 return NULL;
1751}
1752
4c4b4cd2
PH
1753/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1754 position of the field containing the address of the bounds data. */
1755
14f9c5c9 1756static int
d2e4a39e 1757fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1758{
1759 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1760}
1761
1762/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1763 size of the field containing the address of the bounds data. */
1764
14f9c5c9 1765static int
d2e4a39e 1766fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1767{
1768 type = desc_base_type (type);
1769
d2e4a39e 1770 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1771 return TYPE_FIELD_BITSIZE (type, 1);
1772 else
61ee279c 1773 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1774}
1775
4c4b4cd2 1776/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1777 pointer to one, the type of its array data (a array-with-no-bounds type);
1778 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1779 data. */
4c4b4cd2 1780
d2e4a39e 1781static struct type *
556bdfd4 1782desc_data_target_type (struct type *type)
14f9c5c9
AS
1783{
1784 type = desc_base_type (type);
1785
4c4b4cd2 1786 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1787 if (is_thin_pntr (type))
556bdfd4 1788 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1789 else if (is_thick_pntr (type))
556bdfd4
UW
1790 {
1791 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1792
1793 if (data_type
1794 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1795 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1796 }
1797
1798 return NULL;
14f9c5c9
AS
1799}
1800
1801/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1802 its array data. */
4c4b4cd2 1803
d2e4a39e
AS
1804static struct value *
1805desc_data (struct value *arr)
14f9c5c9 1806{
df407dfe 1807 struct type *type = value_type (arr);
5b4ee69b 1808
14f9c5c9
AS
1809 if (is_thin_pntr (type))
1810 return thin_data_pntr (arr);
1811 else if (is_thick_pntr (type))
d2e4a39e 1812 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1813 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1814 else
1815 return NULL;
1816}
1817
1818
1819/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1820 position of the field containing the address of the data. */
1821
14f9c5c9 1822static int
d2e4a39e 1823fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1824{
1825 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1826}
1827
1828/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1829 size of the field containing the address of the data. */
1830
14f9c5c9 1831static int
d2e4a39e 1832fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1833{
1834 type = desc_base_type (type);
1835
1836 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1837 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1838 else
14f9c5c9
AS
1839 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1840}
1841
4c4b4cd2 1842/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1843 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1844 bound, if WHICH is 1. The first bound is I=1. */
1845
d2e4a39e
AS
1846static struct value *
1847desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1848{
d2e4a39e 1849 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1850 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1851}
1852
1853/* If BOUNDS is an array-bounds structure type, return the bit position
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
14f9c5c9 1857static int
d2e4a39e 1858desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1859{
d2e4a39e 1860 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1861}
1862
1863/* If BOUNDS is an array-bounds structure type, return the bit field size
1864 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1865 bound, if WHICH is 1. The first bound is I=1. */
1866
76a01679 1867static int
d2e4a39e 1868desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1869{
1870 type = desc_base_type (type);
1871
d2e4a39e
AS
1872 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1873 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1874 else
1875 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1876}
1877
1878/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1879 Ith bound (numbering from 1). Otherwise, NULL. */
1880
d2e4a39e
AS
1881static struct type *
1882desc_index_type (struct type *type, int i)
14f9c5c9
AS
1883{
1884 type = desc_base_type (type);
1885
1886 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1887 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1888 else
14f9c5c9
AS
1889 return NULL;
1890}
1891
4c4b4cd2
PH
1892/* The number of index positions in the array-bounds type TYPE.
1893 Return 0 if TYPE is NULL. */
1894
14f9c5c9 1895static int
d2e4a39e 1896desc_arity (struct type *type)
14f9c5c9
AS
1897{
1898 type = desc_base_type (type);
1899
1900 if (type != NULL)
1901 return TYPE_NFIELDS (type) / 2;
1902 return 0;
1903}
1904
4c4b4cd2
PH
1905/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1906 an array descriptor type (representing an unconstrained array
1907 type). */
1908
76a01679
JB
1909static int
1910ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1911{
1912 if (type == NULL)
1913 return 0;
61ee279c 1914 type = ada_check_typedef (type);
4c4b4cd2 1915 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1916 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1917}
1918
52ce6436 1919/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1920 * to one. */
52ce6436 1921
2c0b251b 1922static int
52ce6436
PH
1923ada_is_array_type (struct type *type)
1924{
1925 while (type != NULL
1926 && (TYPE_CODE (type) == TYPE_CODE_PTR
1927 || TYPE_CODE (type) == TYPE_CODE_REF))
1928 type = TYPE_TARGET_TYPE (type);
1929 return ada_is_direct_array_type (type);
1930}
1931
4c4b4cd2 1932/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1933
14f9c5c9 1934int
4c4b4cd2 1935ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1936{
1937 if (type == NULL)
1938 return 0;
61ee279c 1939 type = ada_check_typedef (type);
14f9c5c9 1940 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1941 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1942 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1943 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1944}
1945
4c4b4cd2
PH
1946/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1947
14f9c5c9 1948int
4c4b4cd2 1949ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1950{
556bdfd4 1951 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1952
1953 if (type == NULL)
1954 return 0;
61ee279c 1955 type = ada_check_typedef (type);
556bdfd4
UW
1956 return (data_type != NULL
1957 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1958 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1959}
1960
1961/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1962 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1963 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1964 is still needed. */
1965
14f9c5c9 1966int
ebf56fd3 1967ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1968{
d2e4a39e 1969 return
14f9c5c9
AS
1970 type != NULL
1971 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1972 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1973 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1974 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1975}
1976
1977
4c4b4cd2 1978/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1979 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1980 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1981 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1982 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1983 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1984 a descriptor. */
d2e4a39e
AS
1985struct type *
1986ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1987{
ad82864c
JB
1988 if (ada_is_constrained_packed_array_type (value_type (arr)))
1989 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1990
df407dfe
AC
1991 if (!ada_is_array_descriptor_type (value_type (arr)))
1992 return value_type (arr);
d2e4a39e
AS
1993
1994 if (!bounds)
ad82864c
JB
1995 {
1996 struct type *array_type =
1997 ada_check_typedef (desc_data_target_type (value_type (arr)));
1998
1999 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2000 TYPE_FIELD_BITSIZE (array_type, 0) =
2001 decode_packed_array_bitsize (value_type (arr));
2002
2003 return array_type;
2004 }
14f9c5c9
AS
2005 else
2006 {
d2e4a39e 2007 struct type *elt_type;
14f9c5c9 2008 int arity;
d2e4a39e 2009 struct value *descriptor;
14f9c5c9 2010
df407dfe
AC
2011 elt_type = ada_array_element_type (value_type (arr), -1);
2012 arity = ada_array_arity (value_type (arr));
14f9c5c9 2013
d2e4a39e 2014 if (elt_type == NULL || arity == 0)
df407dfe 2015 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2016
2017 descriptor = desc_bounds (arr);
d2e4a39e 2018 if (value_as_long (descriptor) == 0)
4c4b4cd2 2019 return NULL;
d2e4a39e 2020 while (arity > 0)
4c4b4cd2 2021 {
e9bb382b
UW
2022 struct type *range_type = alloc_type_copy (value_type (arr));
2023 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2024 struct value *low = desc_one_bound (descriptor, arity, 0);
2025 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2026
5b4ee69b 2027 arity -= 1;
0c9c3474
SA
2028 create_static_range_type (range_type, value_type (low),
2029 longest_to_int (value_as_long (low)),
2030 longest_to_int (value_as_long (high)));
4c4b4cd2 2031 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2032
2033 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2034 {
2035 /* We need to store the element packed bitsize, as well as
2036 recompute the array size, because it was previously
2037 computed based on the unpacked element size. */
2038 LONGEST lo = value_as_long (low);
2039 LONGEST hi = value_as_long (high);
2040
2041 TYPE_FIELD_BITSIZE (elt_type, 0) =
2042 decode_packed_array_bitsize (value_type (arr));
2043 /* If the array has no element, then the size is already
2044 zero, and does not need to be recomputed. */
2045 if (lo < hi)
2046 {
2047 int array_bitsize =
2048 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2049
2050 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2051 }
2052 }
4c4b4cd2 2053 }
14f9c5c9
AS
2054
2055 return lookup_pointer_type (elt_type);
2056 }
2057}
2058
2059/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2060 Otherwise, returns either a standard GDB array with bounds set
2061 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2062 GDB array. Returns NULL if ARR is a null fat pointer. */
2063
d2e4a39e
AS
2064struct value *
2065ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2066{
df407dfe 2067 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2068 {
d2e4a39e 2069 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2070
14f9c5c9 2071 if (arrType == NULL)
4c4b4cd2 2072 return NULL;
14f9c5c9
AS
2073 return value_cast (arrType, value_copy (desc_data (arr)));
2074 }
ad82864c
JB
2075 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2076 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2077 else
2078 return arr;
2079}
2080
2081/* If ARR does not represent an array, returns ARR unchanged.
2082 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2083 be ARR itself if it already is in the proper form). */
2084
720d1a40 2085struct value *
d2e4a39e 2086ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2087{
df407dfe 2088 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2089 {
d2e4a39e 2090 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2091
14f9c5c9 2092 if (arrVal == NULL)
323e0a4a 2093 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2094 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2095 return value_ind (arrVal);
2096 }
ad82864c
JB
2097 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2098 return decode_constrained_packed_array (arr);
d2e4a39e 2099 else
14f9c5c9
AS
2100 return arr;
2101}
2102
2103/* If TYPE represents a GNAT array type, return it translated to an
2104 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2105 packing). For other types, is the identity. */
2106
d2e4a39e
AS
2107struct type *
2108ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2109{
ad82864c
JB
2110 if (ada_is_constrained_packed_array_type (type))
2111 return decode_constrained_packed_array_type (type);
17280b9f
UW
2112
2113 if (ada_is_array_descriptor_type (type))
556bdfd4 2114 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2115
2116 return type;
14f9c5c9
AS
2117}
2118
4c4b4cd2
PH
2119/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2120
ad82864c
JB
2121static int
2122ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2123{
2124 if (type == NULL)
2125 return 0;
4c4b4cd2 2126 type = desc_base_type (type);
61ee279c 2127 type = ada_check_typedef (type);
d2e4a39e 2128 return
14f9c5c9
AS
2129 ada_type_name (type) != NULL
2130 && strstr (ada_type_name (type), "___XP") != NULL;
2131}
2132
ad82864c
JB
2133/* Non-zero iff TYPE represents a standard GNAT constrained
2134 packed-array type. */
2135
2136int
2137ada_is_constrained_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/* Non-zero iff TYPE represents an array descriptor for a
2144 unconstrained packed-array type. */
2145
2146static int
2147ada_is_unconstrained_packed_array_type (struct type *type)
2148{
2149 return ada_is_packed_array_type (type)
2150 && ada_is_array_descriptor_type (type);
2151}
2152
2153/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2154 return the size of its elements in bits. */
2155
2156static long
2157decode_packed_array_bitsize (struct type *type)
2158{
0d5cff50
DE
2159 const char *raw_name;
2160 const char *tail;
ad82864c
JB
2161 long bits;
2162
720d1a40
JB
2163 /* Access to arrays implemented as fat pointers are encoded as a typedef
2164 of the fat pointer type. We need the name of the fat pointer type
2165 to do the decoding, so strip the typedef layer. */
2166 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2167 type = ada_typedef_target_type (type);
2168
2169 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2170 if (!raw_name)
2171 raw_name = ada_type_name (desc_base_type (type));
2172
2173 if (!raw_name)
2174 return 0;
2175
2176 tail = strstr (raw_name, "___XP");
720d1a40 2177 gdb_assert (tail != NULL);
ad82864c
JB
2178
2179 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2180 {
2181 lim_warning
2182 (_("could not understand bit size information on packed array"));
2183 return 0;
2184 }
2185
2186 return bits;
2187}
2188
14f9c5c9
AS
2189/* Given that TYPE is a standard GDB array type with all bounds filled
2190 in, and that the element size of its ultimate scalar constituents
2191 (that is, either its elements, or, if it is an array of arrays, its
2192 elements' elements, etc.) is *ELT_BITS, return an identical type,
2193 but with the bit sizes of its elements (and those of any
2194 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2195 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2196 in bits.
2197
2198 Note that, for arrays whose index type has an XA encoding where
2199 a bound references a record discriminant, getting that discriminant,
2200 and therefore the actual value of that bound, is not possible
2201 because none of the given parameters gives us access to the record.
2202 This function assumes that it is OK in the context where it is being
2203 used to return an array whose bounds are still dynamic and where
2204 the length is arbitrary. */
4c4b4cd2 2205
d2e4a39e 2206static struct type *
ad82864c 2207constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2208{
d2e4a39e
AS
2209 struct type *new_elt_type;
2210 struct type *new_type;
99b1c762
JB
2211 struct type *index_type_desc;
2212 struct type *index_type;
14f9c5c9
AS
2213 LONGEST low_bound, high_bound;
2214
61ee279c 2215 type = ada_check_typedef (type);
14f9c5c9
AS
2216 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2217 return type;
2218
99b1c762
JB
2219 index_type_desc = ada_find_parallel_type (type, "___XA");
2220 if (index_type_desc)
2221 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2222 NULL);
2223 else
2224 index_type = TYPE_INDEX_TYPE (type);
2225
e9bb382b 2226 new_type = alloc_type_copy (type);
ad82864c
JB
2227 new_elt_type =
2228 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2229 elt_bits);
99b1c762 2230 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2231 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2232 TYPE_NAME (new_type) = ada_type_name (type);
2233
4a46959e
JB
2234 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2235 && is_dynamic_type (check_typedef (index_type)))
2236 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2237 low_bound = high_bound = 0;
2238 if (high_bound < low_bound)
2239 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2240 else
14f9c5c9
AS
2241 {
2242 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2243 TYPE_LENGTH (new_type) =
4c4b4cd2 2244 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2245 }
2246
876cecd0 2247 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2248 return new_type;
2249}
2250
ad82864c
JB
2251/* The array type encoded by TYPE, where
2252 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2253
d2e4a39e 2254static struct type *
ad82864c 2255decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2256{
0d5cff50 2257 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2258 char *name;
0d5cff50 2259 const char *tail;
d2e4a39e 2260 struct type *shadow_type;
14f9c5c9 2261 long bits;
14f9c5c9 2262
727e3d2e
JB
2263 if (!raw_name)
2264 raw_name = ada_type_name (desc_base_type (type));
2265
2266 if (!raw_name)
2267 return NULL;
2268
2269 name = (char *) alloca (strlen (raw_name) + 1);
2270 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2271 type = desc_base_type (type);
2272
14f9c5c9
AS
2273 memcpy (name, raw_name, tail - raw_name);
2274 name[tail - raw_name] = '\000';
2275
b4ba55a1
JB
2276 shadow_type = ada_find_parallel_type_with_name (type, name);
2277
2278 if (shadow_type == NULL)
14f9c5c9 2279 {
323e0a4a 2280 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2281 return NULL;
2282 }
f168693b 2283 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2284
2285 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2286 {
0963b4bd
MS
2287 lim_warning (_("could not understand bounds "
2288 "information on packed array"));
14f9c5c9
AS
2289 return NULL;
2290 }
d2e4a39e 2291
ad82864c
JB
2292 bits = decode_packed_array_bitsize (type);
2293 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2294}
2295
ad82864c
JB
2296/* Given that ARR is a struct value *indicating a GNAT constrained packed
2297 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2298 standard GDB array type except that the BITSIZEs of the array
2299 target types are set to the number of bits in each element, and the
4c4b4cd2 2300 type length is set appropriately. */
14f9c5c9 2301
d2e4a39e 2302static struct value *
ad82864c 2303decode_constrained_packed_array (struct value *arr)
14f9c5c9 2304{
4c4b4cd2 2305 struct type *type;
14f9c5c9 2306
11aa919a
PMR
2307 /* If our value is a pointer, then dereference it. Likewise if
2308 the value is a reference. Make sure that this operation does not
2309 cause the target type to be fixed, as this would indirectly cause
2310 this array to be decoded. The rest of the routine assumes that
2311 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2312 and "value_ind" routines to perform the dereferencing, as opposed
2313 to using "ada_coerce_ref" or "ada_value_ind". */
2314 arr = coerce_ref (arr);
828292f2 2315 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2316 arr = value_ind (arr);
4c4b4cd2 2317
ad82864c 2318 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2319 if (type == NULL)
2320 {
323e0a4a 2321 error (_("can't unpack array"));
14f9c5c9
AS
2322 return NULL;
2323 }
61ee279c 2324
50810684 2325 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2326 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2327 {
2328 /* This is a (right-justified) modular type representing a packed
2329 array with no wrapper. In order to interpret the value through
2330 the (left-justified) packed array type we just built, we must
2331 first left-justify it. */
2332 int bit_size, bit_pos;
2333 ULONGEST mod;
2334
df407dfe 2335 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2336 bit_size = 0;
2337 while (mod > 0)
2338 {
2339 bit_size += 1;
2340 mod >>= 1;
2341 }
df407dfe 2342 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2343 arr = ada_value_primitive_packed_val (arr, NULL,
2344 bit_pos / HOST_CHAR_BIT,
2345 bit_pos % HOST_CHAR_BIT,
2346 bit_size,
2347 type);
2348 }
2349
4c4b4cd2 2350 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2351}
2352
2353
2354/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2355 given in IND. ARR must be a simple array. */
14f9c5c9 2356
d2e4a39e
AS
2357static struct value *
2358value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2359{
2360 int i;
2361 int bits, elt_off, bit_off;
2362 long elt_total_bit_offset;
d2e4a39e
AS
2363 struct type *elt_type;
2364 struct value *v;
14f9c5c9
AS
2365
2366 bits = 0;
2367 elt_total_bit_offset = 0;
df407dfe 2368 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2369 for (i = 0; i < arity; i += 1)
14f9c5c9 2370 {
d2e4a39e 2371 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2372 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2373 error
0963b4bd
MS
2374 (_("attempt to do packed indexing of "
2375 "something other than a packed array"));
14f9c5c9 2376 else
4c4b4cd2
PH
2377 {
2378 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2379 LONGEST lowerbound, upperbound;
2380 LONGEST idx;
2381
2382 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2383 {
323e0a4a 2384 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2385 lowerbound = upperbound = 0;
2386 }
2387
3cb382c9 2388 idx = pos_atr (ind[i]);
4c4b4cd2 2389 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2390 lim_warning (_("packed array index %ld out of bounds"),
2391 (long) idx);
4c4b4cd2
PH
2392 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2393 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2394 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2395 }
14f9c5c9
AS
2396 }
2397 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2398 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2399
2400 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2401 bits, elt_type);
14f9c5c9
AS
2402 return v;
2403}
2404
4c4b4cd2 2405/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2406
2407static int
d2e4a39e 2408has_negatives (struct type *type)
14f9c5c9 2409{
d2e4a39e
AS
2410 switch (TYPE_CODE (type))
2411 {
2412 default:
2413 return 0;
2414 case TYPE_CODE_INT:
2415 return !TYPE_UNSIGNED (type);
2416 case TYPE_CODE_RANGE:
2417 return TYPE_LOW_BOUND (type) < 0;
2418 }
14f9c5c9 2419}
d2e4a39e 2420
f93fca70 2421/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2422 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2423 the unpacked buffer.
14f9c5c9 2424
5b639dea
JB
2425 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2426 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2427
f93fca70
JB
2428 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2429 zero otherwise.
14f9c5c9 2430
f93fca70 2431 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2432
f93fca70
JB
2433 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2434
2435static void
2436ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2437 gdb_byte *unpacked, int unpacked_len,
2438 int is_big_endian, int is_signed_type,
2439 int is_scalar)
2440{
a1c95e6b
JB
2441 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2442 int src_idx; /* Index into the source area */
2443 int src_bytes_left; /* Number of source bytes left to process. */
2444 int srcBitsLeft; /* Number of source bits left to move */
2445 int unusedLS; /* Number of bits in next significant
2446 byte of source that are unused */
2447
a1c95e6b
JB
2448 int unpacked_idx; /* Index into the unpacked buffer */
2449 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2450
4c4b4cd2 2451 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2452 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2453 unsigned char sign;
a1c95e6b 2454
4c4b4cd2
PH
2455 /* Transmit bytes from least to most significant; delta is the direction
2456 the indices move. */
f93fca70 2457 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2458
5b639dea
JB
2459 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2460 bits from SRC. .*/
2461 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2462 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2463 bit_size, unpacked_len);
2464
14f9c5c9 2465 srcBitsLeft = bit_size;
086ca51f 2466 src_bytes_left = src_len;
f93fca70 2467 unpacked_bytes_left = unpacked_len;
14f9c5c9 2468 sign = 0;
f93fca70
JB
2469
2470 if (is_big_endian)
14f9c5c9 2471 {
086ca51f 2472 src_idx = src_len - 1;
f93fca70
JB
2473 if (is_signed_type
2474 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2475 sign = ~0;
d2e4a39e
AS
2476
2477 unusedLS =
4c4b4cd2
PH
2478 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2479 % HOST_CHAR_BIT;
14f9c5c9 2480
f93fca70
JB
2481 if (is_scalar)
2482 {
2483 accumSize = 0;
2484 unpacked_idx = unpacked_len - 1;
2485 }
2486 else
2487 {
4c4b4cd2
PH
2488 /* Non-scalar values must be aligned at a byte boundary... */
2489 accumSize =
2490 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2491 /* ... And are placed at the beginning (most-significant) bytes
2492 of the target. */
086ca51f
JB
2493 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2494 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2495 }
14f9c5c9 2496 }
d2e4a39e 2497 else
14f9c5c9
AS
2498 {
2499 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2500
086ca51f 2501 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2502 unusedLS = bit_offset;
2503 accumSize = 0;
2504
f93fca70 2505 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2506 sign = ~0;
14f9c5c9 2507 }
d2e4a39e 2508
14f9c5c9 2509 accum = 0;
086ca51f 2510 while (src_bytes_left > 0)
14f9c5c9
AS
2511 {
2512 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2513 part of the value. */
d2e4a39e 2514 unsigned int unusedMSMask =
4c4b4cd2
PH
2515 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2516 1;
2517 /* Sign-extend bits for this byte. */
14f9c5c9 2518 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2519
d2e4a39e 2520 accum |=
086ca51f 2521 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2522 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2523 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2524 {
db297a65 2525 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2526 accumSize -= HOST_CHAR_BIT;
2527 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2528 unpacked_bytes_left -= 1;
2529 unpacked_idx += delta;
4c4b4cd2 2530 }
14f9c5c9
AS
2531 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2532 unusedLS = 0;
086ca51f
JB
2533 src_bytes_left -= 1;
2534 src_idx += delta;
14f9c5c9 2535 }
086ca51f 2536 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2537 {
2538 accum |= sign << accumSize;
db297a65 2539 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2540 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2541 if (accumSize < 0)
2542 accumSize = 0;
14f9c5c9 2543 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2544 unpacked_bytes_left -= 1;
2545 unpacked_idx += delta;
14f9c5c9 2546 }
f93fca70
JB
2547}
2548
2549/* Create a new value of type TYPE from the contents of OBJ starting
2550 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2551 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2552 assigning through the result will set the field fetched from.
2553 VALADDR is ignored unless OBJ is NULL, in which case,
2554 VALADDR+OFFSET must address the start of storage containing the
2555 packed value. The value returned in this case is never an lval.
2556 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2557
2558struct value *
2559ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2560 long offset, int bit_offset, int bit_size,
2561 struct type *type)
2562{
2563 struct value *v;
bfb1c796 2564 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2565 gdb_byte *unpacked;
220475ed 2566 const int is_scalar = is_scalar_type (type);
d0a9e810 2567 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2568 gdb::byte_vector staging;
f93fca70
JB
2569
2570 type = ada_check_typedef (type);
2571
d0a9e810 2572 if (obj == NULL)
bfb1c796 2573 src = valaddr + offset;
d0a9e810 2574 else
bfb1c796 2575 src = value_contents (obj) + offset;
d0a9e810
JB
2576
2577 if (is_dynamic_type (type))
2578 {
2579 /* The length of TYPE might by dynamic, so we need to resolve
2580 TYPE in order to know its actual size, which we then use
2581 to create the contents buffer of the value we return.
2582 The difficulty is that the data containing our object is
2583 packed, and therefore maybe not at a byte boundary. So, what
2584 we do, is unpack the data into a byte-aligned buffer, and then
2585 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2586 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2587 staging.resize (staging_len);
d0a9e810
JB
2588
2589 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2590 staging.data (), staging.size (),
d0a9e810
JB
2591 is_big_endian, has_negatives (type),
2592 is_scalar);
d5722aa2 2593 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2594 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2595 {
2596 /* This happens when the length of the object is dynamic,
2597 and is actually smaller than the space reserved for it.
2598 For instance, in an array of variant records, the bit_size
2599 we're given is the array stride, which is constant and
2600 normally equal to the maximum size of its element.
2601 But, in reality, each element only actually spans a portion
2602 of that stride. */
2603 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2604 }
d0a9e810
JB
2605 }
2606
f93fca70
JB
2607 if (obj == NULL)
2608 {
2609 v = allocate_value (type);
bfb1c796 2610 src = valaddr + offset;
f93fca70
JB
2611 }
2612 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2613 {
0cafa88c 2614 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2615 gdb_byte *buf;
0cafa88c 2616
f93fca70 2617 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2618 buf = (gdb_byte *) alloca (src_len);
2619 read_memory (value_address (v), buf, src_len);
2620 src = buf;
f93fca70
JB
2621 }
2622 else
2623 {
2624 v = allocate_value (type);
bfb1c796 2625 src = value_contents (obj) + offset;
f93fca70
JB
2626 }
2627
2628 if (obj != NULL)
2629 {
2630 long new_offset = offset;
2631
2632 set_value_component_location (v, obj);
2633 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2634 set_value_bitsize (v, bit_size);
2635 if (value_bitpos (v) >= HOST_CHAR_BIT)
2636 {
2637 ++new_offset;
2638 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2639 }
2640 set_value_offset (v, new_offset);
2641
2642 /* Also set the parent value. This is needed when trying to
2643 assign a new value (in inferior memory). */
2644 set_value_parent (v, obj);
2645 }
2646 else
2647 set_value_bitsize (v, bit_size);
bfb1c796 2648 unpacked = value_contents_writeable (v);
f93fca70
JB
2649
2650 if (bit_size == 0)
2651 {
2652 memset (unpacked, 0, TYPE_LENGTH (type));
2653 return v;
2654 }
2655
d5722aa2 2656 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2657 {
d0a9e810
JB
2658 /* Small short-cut: If we've unpacked the data into a buffer
2659 of the same size as TYPE's length, then we can reuse that,
2660 instead of doing the unpacking again. */
d5722aa2 2661 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2662 }
d0a9e810
JB
2663 else
2664 ada_unpack_from_contents (src, bit_offset, bit_size,
2665 unpacked, TYPE_LENGTH (type),
2666 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2667
14f9c5c9
AS
2668 return v;
2669}
d2e4a39e 2670
14f9c5c9
AS
2671/* Store the contents of FROMVAL into the location of TOVAL.
2672 Return a new value with the location of TOVAL and contents of
2673 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2674 floating-point or non-scalar types. */
14f9c5c9 2675
d2e4a39e
AS
2676static struct value *
2677ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2678{
df407dfe
AC
2679 struct type *type = value_type (toval);
2680 int bits = value_bitsize (toval);
14f9c5c9 2681
52ce6436
PH
2682 toval = ada_coerce_ref (toval);
2683 fromval = ada_coerce_ref (fromval);
2684
2685 if (ada_is_direct_array_type (value_type (toval)))
2686 toval = ada_coerce_to_simple_array (toval);
2687 if (ada_is_direct_array_type (value_type (fromval)))
2688 fromval = ada_coerce_to_simple_array (fromval);
2689
88e3b34b 2690 if (!deprecated_value_modifiable (toval))
323e0a4a 2691 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2692
d2e4a39e 2693 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2694 && bits > 0
d2e4a39e 2695 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2696 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2697 {
df407dfe
AC
2698 int len = (value_bitpos (toval)
2699 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2700 int from_size;
224c3ddb 2701 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2702 struct value *val;
42ae5230 2703 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2704
2705 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2706 fromval = value_cast (type, fromval);
14f9c5c9 2707
52ce6436 2708 read_memory (to_addr, buffer, len);
aced2898
PH
2709 from_size = value_bitsize (fromval);
2710 if (from_size == 0)
2711 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2712 if (gdbarch_bits_big_endian (get_type_arch (type)))
a99bc3d2
JB
2713 copy_bitwise (buffer, value_bitpos (toval),
2714 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2715 else
a99bc3d2
JB
2716 copy_bitwise (buffer, value_bitpos (toval),
2717 value_contents (fromval), 0, bits, 0);
972daa01 2718 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2719
14f9c5c9 2720 val = value_copy (toval);
0fd88904 2721 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2722 TYPE_LENGTH (type));
04624583 2723 deprecated_set_value_type (val, type);
d2e4a39e 2724
14f9c5c9
AS
2725 return val;
2726 }
2727
2728 return value_assign (toval, fromval);
2729}
2730
2731
7c512744
JB
2732/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2733 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2734 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2735 COMPONENT, and not the inferior's memory. The current contents
2736 of COMPONENT are ignored.
2737
2738 Although not part of the initial design, this function also works
2739 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2740 had a null address, and COMPONENT had an address which is equal to
2741 its offset inside CONTAINER. */
2742
52ce6436
PH
2743static void
2744value_assign_to_component (struct value *container, struct value *component,
2745 struct value *val)
2746{
2747 LONGEST offset_in_container =
42ae5230 2748 (LONGEST) (value_address (component) - value_address (container));
7c512744 2749 int bit_offset_in_container =
52ce6436
PH
2750 value_bitpos (component) - value_bitpos (container);
2751 int bits;
7c512744 2752
52ce6436
PH
2753 val = value_cast (value_type (component), val);
2754
2755 if (value_bitsize (component) == 0)
2756 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2757 else
2758 bits = value_bitsize (component);
2759
50810684 2760 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2a62dfa9
JB
2761 {
2762 int src_offset;
2763
2764 if (is_scalar_type (check_typedef (value_type (component))))
2765 src_offset
2766 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2767 else
2768 src_offset = 0;
a99bc3d2
JB
2769 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2770 value_bitpos (container) + bit_offset_in_container,
2771 value_contents (val), src_offset, bits, 1);
2a62dfa9 2772 }
52ce6436 2773 else
a99bc3d2
JB
2774 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2775 value_bitpos (container) + bit_offset_in_container,
2776 value_contents (val), 0, bits, 0);
7c512744
JB
2777}
2778
736ade86
XR
2779/* Determine if TYPE is an access to an unconstrained array. */
2780
d91e9ea8 2781bool
736ade86
XR
2782ada_is_access_to_unconstrained_array (struct type *type)
2783{
2784 return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
2785 && is_thick_pntr (ada_typedef_target_type (type)));
2786}
2787
4c4b4cd2
PH
2788/* The value of the element of array ARR at the ARITY indices given in IND.
2789 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2790 thereto. */
2791
d2e4a39e
AS
2792struct value *
2793ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2794{
2795 int k;
d2e4a39e
AS
2796 struct value *elt;
2797 struct type *elt_type;
14f9c5c9
AS
2798
2799 elt = ada_coerce_to_simple_array (arr);
2800
df407dfe 2801 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2802 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2803 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2804 return value_subscript_packed (elt, arity, ind);
2805
2806 for (k = 0; k < arity; k += 1)
2807 {
b9c50e9a
XR
2808 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2809
14f9c5c9 2810 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2811 error (_("too many subscripts (%d expected)"), k);
b9c50e9a 2812
2497b498 2813 elt = value_subscript (elt, pos_atr (ind[k]));
b9c50e9a
XR
2814
2815 if (ada_is_access_to_unconstrained_array (saved_elt_type)
2816 && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
2817 {
2818 /* The element is a typedef to an unconstrained array,
2819 except that the value_subscript call stripped the
2820 typedef layer. The typedef layer is GNAT's way to
2821 specify that the element is, at the source level, an
2822 access to the unconstrained array, rather than the
2823 unconstrained array. So, we need to restore that
2824 typedef layer, which we can do by forcing the element's
2825 type back to its original type. Otherwise, the returned
2826 value is going to be printed as the array, rather
2827 than as an access. Another symptom of the same issue
2828 would be that an expression trying to dereference the
2829 element would also be improperly rejected. */
2830 deprecated_set_value_type (elt, saved_elt_type);
2831 }
2832
2833 elt_type = ada_check_typedef (value_type (elt));
14f9c5c9 2834 }
b9c50e9a 2835
14f9c5c9
AS
2836 return elt;
2837}
2838
deede10c
JB
2839/* Assuming ARR is a pointer to a GDB array, the value of the element
2840 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2841 Does not read the entire array into memory.
2842
2843 Note: Unlike what one would expect, this function is used instead of
2844 ada_value_subscript for basically all non-packed array types. The reason
2845 for this is that a side effect of doing our own pointer arithmetics instead
2846 of relying on value_subscript is that there is no implicit typedef peeling.
2847 This is important for arrays of array accesses, where it allows us to
2848 preserve the fact that the array's element is an array access, where the
2849 access part os encoded in a typedef layer. */
14f9c5c9 2850
2c0b251b 2851static struct value *
deede10c 2852ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2853{
2854 int k;
919e6dbe 2855 struct value *array_ind = ada_value_ind (arr);
deede10c 2856 struct type *type
919e6dbe
PMR
2857 = check_typedef (value_enclosing_type (array_ind));
2858
2859 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2860 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2861 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2862
2863 for (k = 0; k < arity; k += 1)
2864 {
2865 LONGEST lwb, upb;
aa715135 2866 struct value *lwb_value;
14f9c5c9
AS
2867
2868 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2869 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2870 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2871 value_copy (arr));
14f9c5c9 2872 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2873 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2874 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2875 type = TYPE_TARGET_TYPE (type);
2876 }
2877
2878 return value_ind (arr);
2879}
2880
0b5d8877 2881/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2882 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2883 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2884 this array is LOW, as per Ada rules. */
0b5d8877 2885static struct value *
f5938064
JG
2886ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2887 int low, int high)
0b5d8877 2888{
b0dd7688 2889 struct type *type0 = ada_check_typedef (type);
aa715135 2890 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2891 struct type *index_type
aa715135 2892 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2893 struct type *slice_type = create_array_type_with_stride
2894 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2895 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2896 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2897 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2898 LONGEST base_low_pos, low_pos;
2899 CORE_ADDR base;
2900
2901 if (!discrete_position (base_index_type, low, &low_pos)
2902 || !discrete_position (base_index_type, base_low, &base_low_pos))
2903 {
2904 warning (_("unable to get positions in slice, use bounds instead"));
2905 low_pos = low;
2906 base_low_pos = base_low;
2907 }
5b4ee69b 2908
aa715135
JG
2909 base = value_as_address (array_ptr)
2910 + ((low_pos - base_low_pos)
2911 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2912 return value_at_lazy (slice_type, base);
0b5d8877
PH
2913}
2914
2915
2916static struct value *
2917ada_value_slice (struct value *array, int low, int high)
2918{
b0dd7688 2919 struct type *type = ada_check_typedef (value_type (array));
aa715135 2920 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2921 struct type *index_type
2922 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2923 struct type *slice_type = create_array_type_with_stride
2924 (NULL, TYPE_TARGET_TYPE (type), index_type,
2925 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2926 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2927 LONGEST low_pos, high_pos;
5b4ee69b 2928
aa715135
JG
2929 if (!discrete_position (base_index_type, low, &low_pos)
2930 || !discrete_position (base_index_type, high, &high_pos))
2931 {
2932 warning (_("unable to get positions in slice, use bounds instead"));
2933 low_pos = low;
2934 high_pos = high;
2935 }
2936
2937 return value_cast (slice_type,
2938 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2939}
2940
14f9c5c9
AS
2941/* If type is a record type in the form of a standard GNAT array
2942 descriptor, returns the number of dimensions for type. If arr is a
2943 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2944 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2945
2946int
d2e4a39e 2947ada_array_arity (struct type *type)
14f9c5c9
AS
2948{
2949 int arity;
2950
2951 if (type == NULL)
2952 return 0;
2953
2954 type = desc_base_type (type);
2955
2956 arity = 0;
d2e4a39e 2957 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2958 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2959 else
2960 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2961 {
4c4b4cd2 2962 arity += 1;
61ee279c 2963 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2964 }
d2e4a39e 2965
14f9c5c9
AS
2966 return arity;
2967}
2968
2969/* If TYPE is a record type in the form of a standard GNAT array
2970 descriptor or a simple array type, returns the element type for
2971 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2972 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2973
d2e4a39e
AS
2974struct type *
2975ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2976{
2977 type = desc_base_type (type);
2978
d2e4a39e 2979 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2980 {
2981 int k;
d2e4a39e 2982 struct type *p_array_type;
14f9c5c9 2983
556bdfd4 2984 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2985
2986 k = ada_array_arity (type);
2987 if (k == 0)
4c4b4cd2 2988 return NULL;
d2e4a39e 2989
4c4b4cd2 2990 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2991 if (nindices >= 0 && k > nindices)
4c4b4cd2 2992 k = nindices;
d2e4a39e 2993 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2994 {
61ee279c 2995 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2996 k -= 1;
2997 }
14f9c5c9
AS
2998 return p_array_type;
2999 }
3000 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3001 {
3002 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3003 {
3004 type = TYPE_TARGET_TYPE (type);
3005 nindices -= 1;
3006 }
14f9c5c9
AS
3007 return type;
3008 }
3009
3010 return NULL;
3011}
3012
4c4b4cd2 3013/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3014 Does not examine memory. Throws an error if N is invalid or TYPE
3015 is not an array type. NAME is the name of the Ada attribute being
3016 evaluated ('range, 'first, 'last, or 'length); it is used in building
3017 the error message. */
14f9c5c9 3018
1eea4ebd
UW
3019static struct type *
3020ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3021{
4c4b4cd2
PH
3022 struct type *result_type;
3023
14f9c5c9
AS
3024 type = desc_base_type (type);
3025
1eea4ebd
UW
3026 if (n < 0 || n > ada_array_arity (type))
3027 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3028
4c4b4cd2 3029 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3030 {
3031 int i;
3032
3033 for (i = 1; i < n; i += 1)
4c4b4cd2 3034 type = TYPE_TARGET_TYPE (type);
262452ec 3035 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3036 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3037 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3038 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3039 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3040 result_type = NULL;
14f9c5c9 3041 }
d2e4a39e 3042 else
1eea4ebd
UW
3043 {
3044 result_type = desc_index_type (desc_bounds_type (type), n);
3045 if (result_type == NULL)
3046 error (_("attempt to take bound of something that is not an array"));
3047 }
3048
3049 return result_type;
14f9c5c9
AS
3050}
3051
3052/* Given that arr is an array type, returns the lower bound of the
3053 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3054 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3055 array-descriptor type. It works for other arrays with bounds supplied
3056 by run-time quantities other than discriminants. */
14f9c5c9 3057
abb68b3e 3058static LONGEST
fb5e3d5c 3059ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3060{
8a48ac95 3061 struct type *type, *index_type_desc, *index_type;
1ce677a4 3062 int i;
262452ec
JK
3063
3064 gdb_assert (which == 0 || which == 1);
14f9c5c9 3065
ad82864c
JB
3066 if (ada_is_constrained_packed_array_type (arr_type))
3067 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3068
4c4b4cd2 3069 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3070 return (LONGEST) - which;
14f9c5c9
AS
3071
3072 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3073 type = TYPE_TARGET_TYPE (arr_type);
3074 else
3075 type = arr_type;
3076
bafffb51
JB
3077 if (TYPE_FIXED_INSTANCE (type))
3078 {
3079 /* The array has already been fixed, so we do not need to
3080 check the parallel ___XA type again. That encoding has
3081 already been applied, so ignore it now. */
3082 index_type_desc = NULL;
3083 }
3084 else
3085 {
3086 index_type_desc = ada_find_parallel_type (type, "___XA");
3087 ada_fixup_array_indexes_type (index_type_desc);
3088 }
3089
262452ec 3090 if (index_type_desc != NULL)
28c85d6c
JB
3091 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3092 NULL);
262452ec 3093 else
8a48ac95
JB
3094 {
3095 struct type *elt_type = check_typedef (type);
3096
3097 for (i = 1; i < n; i++)
3098 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3099
3100 index_type = TYPE_INDEX_TYPE (elt_type);
3101 }
262452ec 3102
43bbcdc2
PH
3103 return
3104 (LONGEST) (which == 0
3105 ? ada_discrete_type_low_bound (index_type)
3106 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3107}
3108
3109/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3110 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3111 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3112 supplied by run-time quantities other than discriminants. */
14f9c5c9 3113
1eea4ebd 3114static LONGEST
4dc81987 3115ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3116{
eb479039
JB
3117 struct type *arr_type;
3118
3119 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3120 arr = value_ind (arr);
3121 arr_type = value_enclosing_type (arr);
14f9c5c9 3122
ad82864c
JB
3123 if (ada_is_constrained_packed_array_type (arr_type))
3124 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3125 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3126 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3127 else
1eea4ebd 3128 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3129}
3130
3131/* Given that arr is an array value, returns the length of the
3132 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3133 supplied by run-time quantities other than discriminants.
3134 Does not work for arrays indexed by enumeration types with representation
3135 clauses at the moment. */
14f9c5c9 3136
1eea4ebd 3137static LONGEST
d2e4a39e 3138ada_array_length (struct value *arr, int n)
14f9c5c9 3139{
aa715135
JG
3140 struct type *arr_type, *index_type;
3141 int low, high;
eb479039
JB
3142
3143 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3144 arr = value_ind (arr);
3145 arr_type = value_enclosing_type (arr);
14f9c5c9 3146
ad82864c
JB
3147 if (ada_is_constrained_packed_array_type (arr_type))
3148 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3149
4c4b4cd2 3150 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3151 {
3152 low = ada_array_bound_from_type (arr_type, n, 0);
3153 high = ada_array_bound_from_type (arr_type, n, 1);
3154 }
14f9c5c9 3155 else
aa715135
JG
3156 {
3157 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3158 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3159 }
3160
f168693b 3161 arr_type = check_typedef (arr_type);
7150d33c 3162 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3163 if (index_type != NULL)
3164 {
3165 struct type *base_type;
3166 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3167 base_type = TYPE_TARGET_TYPE (index_type);
3168 else
3169 base_type = index_type;
3170
3171 low = pos_atr (value_from_longest (base_type, low));
3172 high = pos_atr (value_from_longest (base_type, high));
3173 }
3174 return high - low + 1;
4c4b4cd2
PH
3175}
3176
bff8c71f
TT
3177/* An array whose type is that of ARR_TYPE (an array type), with
3178 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3179 less than LOW, then LOW-1 is used. */
4c4b4cd2
PH
3180
3181static struct value *
bff8c71f 3182empty_array (struct type *arr_type, int low, int high)
4c4b4cd2 3183{
b0dd7688 3184 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3185 struct type *index_type
3186 = create_static_range_type
bff8c71f
TT
3187 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low,
3188 high < low ? low - 1 : high);
b0dd7688 3189 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3190
0b5d8877 3191 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3192}
14f9c5c9 3193\f
d2e4a39e 3194
4c4b4cd2 3195 /* Name resolution */
14f9c5c9 3196
4c4b4cd2
PH
3197/* The "decoded" name for the user-definable Ada operator corresponding
3198 to OP. */
14f9c5c9 3199
d2e4a39e 3200static const char *
4c4b4cd2 3201ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3202{
3203 int i;
3204
4c4b4cd2 3205 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3206 {
3207 if (ada_opname_table[i].op == op)
4c4b4cd2 3208 return ada_opname_table[i].decoded;
14f9c5c9 3209 }
323e0a4a 3210 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3211}
3212
3213
4c4b4cd2
PH
3214/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3215 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3216 undefined namespace) and converts operators that are
3217 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3218 non-null, it provides a preferred result type [at the moment, only
3219 type void has any effect---causing procedures to be preferred over
3220 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3221 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3222
4c4b4cd2 3223static void
699bd4cf
TT
3224resolve (expression_up *expp, int void_context_p, int parse_completion,
3225 innermost_block_tracker *tracker)
14f9c5c9 3226{
30b15541
UW
3227 struct type *context_type = NULL;
3228 int pc = 0;
3229
3230 if (void_context_p)
3231 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3232
699bd4cf 3233 resolve_subexp (expp, &pc, 1, context_type, parse_completion, tracker);
14f9c5c9
AS
3234}
3235
4c4b4cd2
PH
3236/* Resolve the operator of the subexpression beginning at
3237 position *POS of *EXPP. "Resolving" consists of replacing
3238 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3239 with their resolutions, replacing built-in operators with
3240 function calls to user-defined operators, where appropriate, and,
3241 when DEPROCEDURE_P is non-zero, converting function-valued variables
3242 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3243 are as in ada_resolve, above. */
14f9c5c9 3244
d2e4a39e 3245static struct value *
e9d9f57e 3246resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
699bd4cf
TT
3247 struct type *context_type, int parse_completion,
3248 innermost_block_tracker *tracker)
14f9c5c9
AS
3249{
3250 int pc = *pos;
3251 int i;
4c4b4cd2 3252 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3253 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3254 struct value **argvec; /* Vector of operand types (alloca'ed). */
3255 int nargs; /* Number of operands. */
52ce6436 3256 int oplen;
14f9c5c9
AS
3257
3258 argvec = NULL;
3259 nargs = 0;
e9d9f57e 3260 exp = expp->get ();
14f9c5c9 3261
52ce6436
PH
3262 /* Pass one: resolve operands, saving their types and updating *pos,
3263 if needed. */
14f9c5c9
AS
3264 switch (op)
3265 {
4c4b4cd2
PH
3266 case OP_FUNCALL:
3267 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3268 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3269 *pos += 7;
4c4b4cd2
PH
3270 else
3271 {
3272 *pos += 3;
699bd4cf 3273 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
4c4b4cd2
PH
3274 }
3275 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3276 break;
3277
14f9c5c9 3278 case UNOP_ADDR:
4c4b4cd2 3279 *pos += 1;
699bd4cf 3280 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
4c4b4cd2
PH
3281 break;
3282
52ce6436
PH
3283 case UNOP_QUAL:
3284 *pos += 3;
2a612529 3285 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type),
699bd4cf 3286 parse_completion, tracker);
4c4b4cd2
PH
3287 break;
3288
52ce6436 3289 case OP_ATR_MODULUS:
4c4b4cd2
PH
3290 case OP_ATR_SIZE:
3291 case OP_ATR_TAG:
4c4b4cd2
PH
3292 case OP_ATR_FIRST:
3293 case OP_ATR_LAST:
3294 case OP_ATR_LENGTH:
3295 case OP_ATR_POS:
3296 case OP_ATR_VAL:
4c4b4cd2
PH
3297 case OP_ATR_MIN:
3298 case OP_ATR_MAX:
52ce6436
PH
3299 case TERNOP_IN_RANGE:
3300 case BINOP_IN_BOUNDS:
3301 case UNOP_IN_RANGE:
3302 case OP_AGGREGATE:
3303 case OP_OTHERS:
3304 case OP_CHOICES:
3305 case OP_POSITIONAL:
3306 case OP_DISCRETE_RANGE:
3307 case OP_NAME:
3308 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3309 *pos += oplen;
14f9c5c9
AS
3310 break;
3311
3312 case BINOP_ASSIGN:
3313 {
4c4b4cd2
PH
3314 struct value *arg1;
3315
3316 *pos += 1;
699bd4cf 3317 arg1 = resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
4c4b4cd2 3318 if (arg1 == NULL)
699bd4cf 3319 resolve_subexp (expp, pos, 1, NULL, parse_completion, tracker);
4c4b4cd2 3320 else
699bd4cf
TT
3321 resolve_subexp (expp, pos, 1, value_type (arg1), parse_completion,
3322 tracker);
4c4b4cd2 3323 break;
14f9c5c9
AS
3324 }
3325
4c4b4cd2 3326 case UNOP_CAST:
4c4b4cd2
PH
3327 *pos += 3;
3328 nargs = 1;
3329 break;
14f9c5c9 3330
4c4b4cd2
PH
3331 case BINOP_ADD:
3332 case BINOP_SUB:
3333 case BINOP_MUL:
3334 case BINOP_DIV:
3335 case BINOP_REM:
3336 case BINOP_MOD:
3337 case BINOP_EXP:
3338 case BINOP_CONCAT:
3339 case BINOP_LOGICAL_AND:
3340 case BINOP_LOGICAL_OR:
3341 case BINOP_BITWISE_AND:
3342 case BINOP_BITWISE_IOR:
3343 case BINOP_BITWISE_XOR:
14f9c5c9 3344
4c4b4cd2
PH
3345 case BINOP_EQUAL:
3346 case BINOP_NOTEQUAL:
3347 case BINOP_LESS:
3348 case BINOP_GTR:
3349 case BINOP_LEQ:
3350 case BINOP_GEQ:
14f9c5c9 3351
4c4b4cd2
PH
3352 case BINOP_REPEAT:
3353 case BINOP_SUBSCRIPT:
3354 case BINOP_COMMA:
40c8aaa9
JB
3355 *pos += 1;
3356 nargs = 2;
3357 break;
14f9c5c9 3358
4c4b4cd2
PH
3359 case UNOP_NEG:
3360 case UNOP_PLUS:
3361 case UNOP_LOGICAL_NOT:
3362 case UNOP_ABS:
3363 case UNOP_IND:
3364 *pos += 1;
3365 nargs = 1;
3366 break;
14f9c5c9 3367
4c4b4cd2 3368 case OP_LONG:
edd079d9 3369 case OP_FLOAT:
4c4b4cd2 3370 case OP_VAR_VALUE:
74ea4be4 3371 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3372 *pos += 4;
3373 break;
14f9c5c9 3374
4c4b4cd2
PH
3375 case OP_TYPE:
3376 case OP_BOOL:
3377 case OP_LAST:
4c4b4cd2
PH
3378 case OP_INTERNALVAR:
3379 *pos += 3;
3380 break;
14f9c5c9 3381
4c4b4cd2
PH
3382 case UNOP_MEMVAL:
3383 *pos += 3;
3384 nargs = 1;
3385 break;
3386
67f3407f
DJ
3387 case OP_REGISTER:
3388 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3389 break;
3390
4c4b4cd2
PH
3391 case STRUCTOP_STRUCT:
3392 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3393 nargs = 1;
3394 break;
3395
4c4b4cd2 3396 case TERNOP_SLICE:
4c4b4cd2
PH
3397 *pos += 1;
3398 nargs = 3;
3399 break;
3400
52ce6436 3401 case OP_STRING:
14f9c5c9 3402 break;
4c4b4cd2
PH
3403
3404 default:
323e0a4a 3405 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3406 }
3407
8d749320 3408 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2 3409 for (i = 0; i < nargs; i += 1)
699bd4cf
TT
3410 argvec[i] = resolve_subexp (expp, pos, 1, NULL, parse_completion,
3411 tracker);
4c4b4cd2 3412 argvec[i] = NULL;
e9d9f57e 3413 exp = expp->get ();
4c4b4cd2
PH
3414
3415 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3416 switch (op)
3417 {
3418 default:
3419 break;
3420
14f9c5c9 3421 case OP_VAR_VALUE:
4c4b4cd2 3422 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3423 {
54d343a2 3424 std::vector<struct block_symbol> candidates;
76a01679
JB
3425 int n_candidates;
3426
3427 n_candidates =
3428 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3429 (exp->elts[pc + 2].symbol),
3430 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3431 &candidates);
76a01679
JB
3432
3433 if (n_candidates > 1)
3434 {
3435 /* Types tend to get re-introduced locally, so if there
3436 are any local symbols that are not types, first filter
3437 out all types. */
3438 int j;
3439 for (j = 0; j < n_candidates; j += 1)
d12307c1 3440 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3441 {
3442 case LOC_REGISTER:
3443 case LOC_ARG:
3444 case LOC_REF_ARG:
76a01679
JB
3445 case LOC_REGPARM_ADDR:
3446 case LOC_LOCAL:
76a01679 3447 case LOC_COMPUTED:
76a01679
JB
3448 goto FoundNonType;
3449 default:
3450 break;
3451 }
3452 FoundNonType:
3453 if (j < n_candidates)
3454 {
3455 j = 0;
3456 while (j < n_candidates)
3457 {
d12307c1 3458 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3459 {
3460 candidates[j] = candidates[n_candidates - 1];
3461 n_candidates -= 1;
3462 }
3463 else
3464 j += 1;
3465 }
3466 }
3467 }
3468
3469 if (n_candidates == 0)
323e0a4a 3470 error (_("No definition found for %s"),
76a01679
JB
3471 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3472 else if (n_candidates == 1)
3473 i = 0;
3474 else if (deprocedure_p
54d343a2 3475 && !is_nonfunction (candidates.data (), n_candidates))
76a01679 3476 {
06d5cf63 3477 i = ada_resolve_function
54d343a2 3478 (candidates.data (), n_candidates, NULL, 0,
06d5cf63 3479 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2a612529 3480 context_type, parse_completion);
76a01679 3481 if (i < 0)
323e0a4a 3482 error (_("Could not find a match for %s"),
76a01679
JB
3483 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3484 }
3485 else
3486 {
323e0a4a 3487 printf_filtered (_("Multiple matches for %s\n"),
76a01679 3488 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
54d343a2 3489 user_select_syms (candidates.data (), n_candidates, 1);
76a01679
JB
3490 i = 0;
3491 }
3492
3493 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3494 exp->elts[pc + 2].symbol = candidates[i].symbol;
699bd4cf 3495 tracker->update (candidates[i]);
76a01679
JB
3496 }
3497
3498 if (deprocedure_p
3499 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3500 == TYPE_CODE_FUNC))
3501 {
424da6cf 3502 replace_operator_with_call (expp, pc, 0, 4,
76a01679
JB
3503 exp->elts[pc + 2].symbol,
3504 exp->elts[pc + 1].block);
e9d9f57e 3505 exp = expp->get ();
76a01679 3506 }
14f9c5c9
AS
3507 break;
3508
3509 case OP_FUNCALL:
3510 {
4c4b4cd2 3511 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3512 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3513 {
54d343a2 3514 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3515 int n_candidates;
3516
3517 n_candidates =
76a01679
JB
3518 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3519 (exp->elts[pc + 5].symbol),
3520 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3521 &candidates);
ec6a20c2 3522
4c4b4cd2
PH
3523 if (n_candidates == 1)
3524 i = 0;
3525 else
3526 {
06d5cf63 3527 i = ada_resolve_function
54d343a2 3528 (candidates.data (), n_candidates,
06d5cf63
JB
3529 argvec, nargs,
3530 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2a612529 3531 context_type, parse_completion);
4c4b4cd2 3532 if (i < 0)
323e0a4a 3533 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3534 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3535 }
3536
3537 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3538 exp->elts[pc + 5].symbol = candidates[i].symbol;
699bd4cf 3539 tracker->update (candidates[i]);
4c4b4cd2 3540 }
14f9c5c9
AS
3541 }
3542 break;
3543 case BINOP_ADD:
3544 case BINOP_SUB:
3545 case BINOP_MUL:
3546 case BINOP_DIV:
3547 case BINOP_REM:
3548 case BINOP_MOD:
3549 case BINOP_CONCAT:
3550 case BINOP_BITWISE_AND:
3551 case BINOP_BITWISE_IOR:
3552 case BINOP_BITWISE_XOR:
3553 case BINOP_EQUAL:
3554 case BINOP_NOTEQUAL:
3555 case BINOP_LESS:
3556 case BINOP_GTR:
3557 case BINOP_LEQ:
3558 case BINOP_GEQ:
3559 case BINOP_EXP:
3560 case UNOP_NEG:
3561 case UNOP_PLUS:
3562 case UNOP_LOGICAL_NOT:
3563 case UNOP_ABS:
3564 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3565 {
54d343a2 3566 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3567 int n_candidates;
3568
3569 n_candidates =
b5ec771e 3570 ada_lookup_symbol_list (ada_decoded_op_name (op),
582942f4 3571 NULL, VAR_DOMAIN,
4eeaa230 3572 &candidates);
ec6a20c2 3573
54d343a2 3574 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
2a612529
TT
3575 nargs, ada_decoded_op_name (op), NULL,
3576 parse_completion);
4c4b4cd2
PH
3577 if (i < 0)
3578 break;
3579
d12307c1
PMR
3580 replace_operator_with_call (expp, pc, nargs, 1,
3581 candidates[i].symbol,
3582 candidates[i].block);
e9d9f57e 3583 exp = expp->get ();
4c4b4cd2 3584 }
14f9c5c9 3585 break;
4c4b4cd2
PH
3586
3587 case OP_TYPE:
b3dbf008 3588 case OP_REGISTER:
4c4b4cd2 3589 return NULL;
14f9c5c9
AS
3590 }
3591
3592 *pos = pc;
ced9779b
JB
3593 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3594 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3595 exp->elts[pc + 1].objfile,
3596 exp->elts[pc + 2].msymbol);
3597 else
3598 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3599}
3600
3601/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3602 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3603 a non-pointer. */
14f9c5c9 3604/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3605 liberal. */
14f9c5c9
AS
3606
3607static int
4dc81987 3608ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3609{
61ee279c
PH
3610 ftype = ada_check_typedef (ftype);
3611 atype = ada_check_typedef (atype);
14f9c5c9
AS
3612
3613 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3614 ftype = TYPE_TARGET_TYPE (ftype);
3615 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3616 atype = TYPE_TARGET_TYPE (atype);
3617
d2e4a39e 3618 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3619 {
3620 default:
5b3d5b7d 3621 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3622 case TYPE_CODE_PTR:
3623 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3624 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3625 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3626 else
1265e4aa
JB
3627 return (may_deref
3628 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3629 case TYPE_CODE_INT:
3630 case TYPE_CODE_ENUM:
3631 case TYPE_CODE_RANGE:
3632 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3633 {
3634 case TYPE_CODE_INT:
3635 case TYPE_CODE_ENUM:
3636 case TYPE_CODE_RANGE:
3637 return 1;
3638 default:
3639 return 0;
3640 }
14f9c5c9
AS
3641
3642 case TYPE_CODE_ARRAY:
d2e4a39e 3643 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3644 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3645
3646 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3647 if (ada_is_array_descriptor_type (ftype))
3648 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3649 || ada_is_array_descriptor_type (atype));
14f9c5c9 3650 else
4c4b4cd2
PH
3651 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3652 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3653
3654 case TYPE_CODE_UNION:
3655 case TYPE_CODE_FLT:
3656 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3657 }
3658}
3659
3660/* Return non-zero if the formals of FUNC "sufficiently match" the
3661 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3662 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3663 argument function. */
14f9c5c9
AS
3664
3665static int
d2e4a39e 3666ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3667{
3668 int i;
d2e4a39e 3669 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3670
1265e4aa
JB
3671 if (SYMBOL_CLASS (func) == LOC_CONST
3672 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3673 return (n_actuals == 0);
3674 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3675 return 0;
3676
3677 if (TYPE_NFIELDS (func_type) != n_actuals)
3678 return 0;
3679
3680 for (i = 0; i < n_actuals; i += 1)
3681 {
4c4b4cd2 3682 if (actuals[i] == NULL)
76a01679
JB
3683 return 0;
3684 else
3685 {
5b4ee69b
MS
3686 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3687 i));
df407dfe 3688 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3689
76a01679
JB
3690 if (!ada_type_match (ftype, atype, 1))
3691 return 0;
3692 }
14f9c5c9
AS
3693 }
3694 return 1;
3695}
3696
3697/* False iff function type FUNC_TYPE definitely does not produce a value
3698 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3699 FUNC_TYPE is not a valid function type with a non-null return type
3700 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3701
3702static int
d2e4a39e 3703return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3704{
d2e4a39e 3705 struct type *return_type;
14f9c5c9
AS
3706
3707 if (func_type == NULL)
3708 return 1;
3709
4c4b4cd2 3710 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3711 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3712 else
18af8284 3713 return_type = get_base_type (func_type);
14f9c5c9
AS
3714 if (return_type == NULL)
3715 return 1;
3716
18af8284 3717 context_type = get_base_type (context_type);
14f9c5c9
AS
3718
3719 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3720 return context_type == NULL || return_type == context_type;
3721 else if (context_type == NULL)
3722 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3723 else
3724 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3725}
3726
3727
4c4b4cd2 3728/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3729 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3730 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3731 that returns that type, then eliminate matches that don't. If
3732 CONTEXT_TYPE is void and there is at least one match that does not
3733 return void, eliminate all matches that do.
3734
14f9c5c9
AS
3735 Asks the user if there is more than one match remaining. Returns -1
3736 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3737 solely for messages. May re-arrange and modify SYMS in
3738 the process; the index returned is for the modified vector. */
14f9c5c9 3739
4c4b4cd2 3740static int
d12307c1 3741ada_resolve_function (struct block_symbol syms[],
4c4b4cd2 3742 int nsyms, struct value **args, int nargs,
2a612529
TT
3743 const char *name, struct type *context_type,
3744 int parse_completion)
14f9c5c9 3745{
30b15541 3746 int fallback;
14f9c5c9 3747 int k;
4c4b4cd2 3748 int m; /* Number of hits */
14f9c5c9 3749
d2e4a39e 3750 m = 0;
30b15541
UW
3751 /* In the first pass of the loop, we only accept functions matching
3752 context_type. If none are found, we add a second pass of the loop
3753 where every function is accepted. */
3754 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3755 {
3756 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3757 {
d12307c1 3758 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3759
d12307c1 3760 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3761 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3762 {
3763 syms[m] = syms[k];
3764 m += 1;
3765 }
3766 }
14f9c5c9
AS
3767 }
3768
dc5c8746
PMR
3769 /* If we got multiple matches, ask the user which one to use. Don't do this
3770 interactive thing during completion, though, as the purpose of the
3771 completion is providing a list of all possible matches. Prompting the
3772 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3773 if (m == 0)
3774 return -1;
dc5c8746 3775 else if (m > 1 && !parse_completion)
14f9c5c9 3776 {
323e0a4a 3777 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3778 user_select_syms (syms, m, 1);
14f9c5c9
AS
3779 return 0;
3780 }
3781 return 0;
3782}
3783
4c4b4cd2
PH
3784/* Returns true (non-zero) iff decoded name N0 should appear before N1
3785 in a listing of choices during disambiguation (see sort_choices, below).
3786 The idea is that overloadings of a subprogram name from the
3787 same package should sort in their source order. We settle for ordering
3788 such symbols by their trailing number (__N or $N). */
3789
14f9c5c9 3790static int
0d5cff50 3791encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3792{
3793 if (N1 == NULL)
3794 return 0;
3795 else if (N0 == NULL)
3796 return 1;
3797 else
3798 {
3799 int k0, k1;
5b4ee69b 3800
d2e4a39e 3801 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3802 ;
d2e4a39e 3803 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3804 ;
d2e4a39e 3805 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3806 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3807 {
3808 int n0, n1;
5b4ee69b 3809
4c4b4cd2
PH
3810 n0 = k0;
3811 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3812 n0 -= 1;
3813 n1 = k1;
3814 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3815 n1 -= 1;
3816 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3817 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3818 }
14f9c5c9
AS
3819 return (strcmp (N0, N1) < 0);
3820 }
3821}
d2e4a39e 3822
4c4b4cd2
PH
3823/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3824 encoded names. */
3825
d2e4a39e 3826static void
d12307c1 3827sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3828{
4c4b4cd2 3829 int i;
5b4ee69b 3830
d2e4a39e 3831 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3832 {
d12307c1 3833 struct block_symbol sym = syms[i];
14f9c5c9
AS
3834 int j;
3835
d2e4a39e 3836 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3837 {
d12307c1
PMR
3838 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3839 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3840 break;
3841 syms[j + 1] = syms[j];
3842 }
d2e4a39e 3843 syms[j + 1] = sym;
14f9c5c9
AS
3844 }
3845}
3846
d72413e6
PMR
3847/* Whether GDB should display formals and return types for functions in the
3848 overloads selection menu. */
3849static int print_signatures = 1;
3850
3851/* Print the signature for SYM on STREAM according to the FLAGS options. For
3852 all but functions, the signature is just the name of the symbol. For
3853 functions, this is the name of the function, the list of types for formals
3854 and the return type (if any). */
3855
3856static void
3857ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3858 const struct type_print_options *flags)
3859{
3860 struct type *type = SYMBOL_TYPE (sym);
3861
3862 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3863 if (!print_signatures
3864 || type == NULL
3865 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3866 return;
3867
3868 if (TYPE_NFIELDS (type) > 0)
3869 {
3870 int i;
3871
3872 fprintf_filtered (stream, " (");
3873 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3874 {
3875 if (i > 0)
3876 fprintf_filtered (stream, "; ");
3877 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3878 flags);
3879 }
3880 fprintf_filtered (stream, ")");
3881 }
3882 if (TYPE_TARGET_TYPE (type) != NULL
3883 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3884 {
3885 fprintf_filtered (stream, " return ");
3886 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3887 }
3888}
3889
4c4b4cd2
PH
3890/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3891 by asking the user (if necessary), returning the number selected,
3892 and setting the first elements of SYMS items. Error if no symbols
3893 selected. */
14f9c5c9
AS
3894
3895/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3896 to be re-integrated one of these days. */
14f9c5c9
AS
3897
3898int
d12307c1 3899user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3900{
3901 int i;
8d749320 3902 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3903 int n_chosen;
3904 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3905 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3906
3907 if (max_results < 1)
323e0a4a 3908 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3909 if (nsyms <= 1)
3910 return nsyms;
3911
717d2f5a
JB
3912 if (select_mode == multiple_symbols_cancel)
3913 error (_("\
3914canceled because the command is ambiguous\n\
3915See set/show multiple-symbol."));
a0087920 3916
717d2f5a
JB
3917 /* If select_mode is "all", then return all possible symbols.
3918 Only do that if more than one symbol can be selected, of course.
3919 Otherwise, display the menu as usual. */
3920 if (select_mode == multiple_symbols_all && max_results > 1)
3921 return nsyms;
3922
a0087920 3923 printf_filtered (_("[0] cancel\n"));
14f9c5c9 3924 if (max_results > 1)
a0087920 3925 printf_filtered (_("[1] all\n"));
14f9c5c9 3926
4c4b4cd2 3927 sort_choices (syms, nsyms);
14f9c5c9
AS
3928
3929 for (i = 0; i < nsyms; i += 1)
3930 {
d12307c1 3931 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3932 continue;
3933
d12307c1 3934 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3935 {
76a01679 3936 struct symtab_and_line sal =
d12307c1 3937 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3938
a0087920 3939 printf_filtered ("[%d] ", i + first_choice);
d72413e6
PMR
3940 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3941 &type_print_raw_options);
323e0a4a 3942 if (sal.symtab == NULL)
a0087920
TT
3943 printf_filtered (_(" at <no source file available>:%d\n"),
3944 sal.line);
323e0a4a 3945 else
a0087920
TT
3946 printf_filtered (_(" at %s:%d\n"),
3947 symtab_to_filename_for_display (sal.symtab),
3948 sal.line);
4c4b4cd2
PH
3949 continue;
3950 }
d2e4a39e 3951 else
4c4b4cd2
PH
3952 {
3953 int is_enumeral =
d12307c1
PMR
3954 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3955 && SYMBOL_TYPE (syms[i].symbol) != NULL
3956 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3957 struct symtab *symtab = NULL;
3958
d12307c1
PMR
3959 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3960 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3961
d12307c1 3962 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6 3963 {
a0087920 3964 printf_filtered ("[%d] ", i + first_choice);
d72413e6
PMR
3965 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3966 &type_print_raw_options);
a0087920
TT
3967 printf_filtered (_(" at %s:%d\n"),
3968 symtab_to_filename_for_display (symtab),
3969 SYMBOL_LINE (syms[i].symbol));
d72413e6 3970 }
76a01679 3971 else if (is_enumeral
d12307c1 3972 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3973 {
a0087920 3974 printf_filtered (("[%d] "), i + first_choice);
d12307c1 3975 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3976 gdb_stdout, -1, 0, &type_print_raw_options);
a0087920
TT
3977 printf_filtered (_("'(%s) (enumeral)\n"),
3978 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3979 }
d72413e6
PMR
3980 else
3981 {
a0087920 3982 printf_filtered ("[%d] ", i + first_choice);
d72413e6
PMR
3983 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3984 &type_print_raw_options);
3985
3986 if (symtab != NULL)
a0087920
TT
3987 printf_filtered (is_enumeral
3988 ? _(" in %s (enumeral)\n")
3989 : _(" at %s:?\n"),
3990 symtab_to_filename_for_display (symtab));
d72413e6 3991 else
a0087920
TT
3992 printf_filtered (is_enumeral
3993 ? _(" (enumeral)\n")
3994 : _(" at ?\n"));
d72413e6 3995 }
4c4b4cd2 3996 }
14f9c5c9 3997 }
d2e4a39e 3998
14f9c5c9 3999 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4000 "overload-choice");
14f9c5c9
AS
4001
4002 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4003 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4004
4005 return n_chosen;
4006}
4007
4008/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4009 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4010 order in CHOICES[0 .. N-1], and return N.
4011
4012 The user types choices as a sequence of numbers on one line
4013 separated by blanks, encoding them as follows:
4014
4c4b4cd2 4015 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4016 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4017 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4018
4c4b4cd2 4019 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4020
4021 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4022 prompts (for use with the -f switch). */
14f9c5c9
AS
4023
4024int
d2e4a39e 4025get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4026 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4027{
d2e4a39e 4028 char *args;
a121b7c1 4029 const char *prompt;
14f9c5c9
AS
4030 int n_chosen;
4031 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4032
14f9c5c9
AS
4033 prompt = getenv ("PS2");
4034 if (prompt == NULL)
0bcd0149 4035 prompt = "> ";
14f9c5c9 4036
89fbedf3 4037 args = command_line_input (prompt, annotation_suffix);
d2e4a39e 4038
14f9c5c9 4039 if (args == NULL)
323e0a4a 4040 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4041
4042 n_chosen = 0;
76a01679 4043
4c4b4cd2
PH
4044 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4045 order, as given in args. Choices are validated. */
14f9c5c9
AS
4046 while (1)
4047 {
d2e4a39e 4048 char *args2;
14f9c5c9
AS
4049 int choice, j;
4050
0fcd72ba 4051 args = skip_spaces (args);
14f9c5c9 4052 if (*args == '\0' && n_chosen == 0)
323e0a4a 4053 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4054 else if (*args == '\0')
4c4b4cd2 4055 break;
14f9c5c9
AS
4056
4057 choice = strtol (args, &args2, 10);
d2e4a39e 4058 if (args == args2 || choice < 0
4c4b4cd2 4059 || choice > n_choices + first_choice - 1)
323e0a4a 4060 error (_("Argument must be choice number"));
14f9c5c9
AS
4061 args = args2;
4062
d2e4a39e 4063 if (choice == 0)
323e0a4a 4064 error (_("cancelled"));
14f9c5c9
AS
4065
4066 if (choice < first_choice)
4c4b4cd2
PH
4067 {
4068 n_chosen = n_choices;
4069 for (j = 0; j < n_choices; j += 1)
4070 choices[j] = j;
4071 break;
4072 }
14f9c5c9
AS
4073 choice -= first_choice;
4074
d2e4a39e 4075 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4076 {
4077 }
14f9c5c9
AS
4078
4079 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4080 {
4081 int k;
5b4ee69b 4082
4c4b4cd2
PH
4083 for (k = n_chosen - 1; k > j; k -= 1)
4084 choices[k + 1] = choices[k];
4085 choices[j + 1] = choice;
4086 n_chosen += 1;
4087 }
14f9c5c9
AS
4088 }
4089
4090 if (n_chosen > max_results)
323e0a4a 4091 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4092
14f9c5c9
AS
4093 return n_chosen;
4094}
4095
4c4b4cd2
PH
4096/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4097 on the function identified by SYM and BLOCK, and taking NARGS
4098 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4099
4100static void
e9d9f57e 4101replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4102 int oplen, struct symbol *sym,
270140bd 4103 const struct block *block)
14f9c5c9
AS
4104{
4105 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4106 symbol, -oplen for operator being replaced). */
d2e4a39e 4107 struct expression *newexp = (struct expression *)
8c1a34e7 4108 xzalloc (sizeof (struct expression)
4c4b4cd2 4109 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4110 struct expression *exp = expp->get ();
14f9c5c9
AS
4111
4112 newexp->nelts = exp->nelts + 7 - oplen;
4113 newexp->language_defn = exp->language_defn;
3489610d 4114 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4115 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4116 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4117 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4118
4119 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4120 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4121
4122 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4123 newexp->elts[pc + 4].block = block;
4124 newexp->elts[pc + 5].symbol = sym;
4125
e9d9f57e 4126 expp->reset (newexp);
d2e4a39e 4127}
14f9c5c9
AS
4128
4129/* Type-class predicates */
4130
4c4b4cd2
PH
4131/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4132 or FLOAT). */
14f9c5c9
AS
4133
4134static int
d2e4a39e 4135numeric_type_p (struct type *type)
14f9c5c9
AS
4136{
4137 if (type == NULL)
4138 return 0;
d2e4a39e
AS
4139 else
4140 {
4141 switch (TYPE_CODE (type))
4c4b4cd2
PH
4142 {
4143 case TYPE_CODE_INT:
4144 case TYPE_CODE_FLT:
4145 return 1;
4146 case TYPE_CODE_RANGE:
4147 return (type == TYPE_TARGET_TYPE (type)
4148 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4149 default:
4150 return 0;
4151 }
d2e4a39e 4152 }
14f9c5c9
AS
4153}
4154
4c4b4cd2 4155/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4156
4157static int
d2e4a39e 4158integer_type_p (struct type *type)
14f9c5c9
AS
4159{
4160 if (type == NULL)
4161 return 0;
d2e4a39e
AS
4162 else
4163 {
4164 switch (TYPE_CODE (type))
4c4b4cd2
PH
4165 {
4166 case TYPE_CODE_INT:
4167 return 1;
4168 case TYPE_CODE_RANGE:
4169 return (type == TYPE_TARGET_TYPE (type)
4170 || integer_type_p (TYPE_TARGET_TYPE (type)));
4171 default:
4172 return 0;
4173 }
d2e4a39e 4174 }
14f9c5c9
AS
4175}
4176
4c4b4cd2 4177/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4178
4179static int
d2e4a39e 4180scalar_type_p (struct type *type)
14f9c5c9
AS
4181{
4182 if (type == NULL)
4183 return 0;
d2e4a39e
AS
4184 else
4185 {
4186 switch (TYPE_CODE (type))
4c4b4cd2
PH
4187 {
4188 case TYPE_CODE_INT:
4189 case TYPE_CODE_RANGE:
4190 case TYPE_CODE_ENUM:
4191 case TYPE_CODE_FLT:
4192 return 1;
4193 default:
4194 return 0;
4195 }
d2e4a39e 4196 }
14f9c5c9
AS
4197}
4198
4c4b4cd2 4199/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4200
4201static int
d2e4a39e 4202discrete_type_p (struct type *type)
14f9c5c9
AS
4203{
4204 if (type == NULL)
4205 return 0;
d2e4a39e
AS
4206 else
4207 {
4208 switch (TYPE_CODE (type))
4c4b4cd2
PH
4209 {
4210 case TYPE_CODE_INT:
4211 case TYPE_CODE_RANGE:
4212 case TYPE_CODE_ENUM:
872f0337 4213 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4214 return 1;
4215 default:
4216 return 0;
4217 }
d2e4a39e 4218 }
14f9c5c9
AS
4219}
4220
4c4b4cd2
PH
4221/* Returns non-zero if OP with operands in the vector ARGS could be
4222 a user-defined function. Errs on the side of pre-defined operators
4223 (i.e., result 0). */
14f9c5c9
AS
4224
4225static int
d2e4a39e 4226possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4227{
76a01679 4228 struct type *type0 =
df407dfe 4229 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4230 struct type *type1 =
df407dfe 4231 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4232
4c4b4cd2
PH
4233 if (type0 == NULL)
4234 return 0;
4235
14f9c5c9
AS
4236 switch (op)
4237 {
4238 default:
4239 return 0;
4240
4241 case BINOP_ADD:
4242 case BINOP_SUB:
4243 case BINOP_MUL:
4244 case BINOP_DIV:
d2e4a39e 4245 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4246
4247 case BINOP_REM:
4248 case BINOP_MOD:
4249 case BINOP_BITWISE_AND:
4250 case BINOP_BITWISE_IOR:
4251 case BINOP_BITWISE_XOR:
d2e4a39e 4252 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4253
4254 case BINOP_EQUAL:
4255 case BINOP_NOTEQUAL:
4256 case BINOP_LESS:
4257 case BINOP_GTR:
4258 case BINOP_LEQ:
4259 case BINOP_GEQ:
d2e4a39e 4260 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4261
4262 case BINOP_CONCAT:
ee90b9ab 4263 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4264
4265 case BINOP_EXP:
d2e4a39e 4266 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4267
4268 case UNOP_NEG:
4269 case UNOP_PLUS:
4270 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4271 case UNOP_ABS:
4272 return (!numeric_type_p (type0));
14f9c5c9
AS
4273
4274 }
4275}
4276\f
4c4b4cd2 4277 /* Renaming */
14f9c5c9 4278
aeb5907d
JB
4279/* NOTES:
4280
4281 1. In the following, we assume that a renaming type's name may
4282 have an ___XD suffix. It would be nice if this went away at some
4283 point.
4284 2. We handle both the (old) purely type-based representation of
4285 renamings and the (new) variable-based encoding. At some point,
4286 it is devoutly to be hoped that the former goes away
4287 (FIXME: hilfinger-2007-07-09).
4288 3. Subprogram renamings are not implemented, although the XRS
4289 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4290
4291/* If SYM encodes a renaming,
4292
4293 <renaming> renames <renamed entity>,
4294
4295 sets *LEN to the length of the renamed entity's name,
4296 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4297 the string describing the subcomponent selected from the renamed
0963b4bd 4298 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4299 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4300 are undefined). Otherwise, returns a value indicating the category
4301 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4302 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4303 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4304 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4305 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4306 may be NULL, in which case they are not assigned.
4307
4308 [Currently, however, GCC does not generate subprogram renamings.] */
4309
4310enum ada_renaming_category
4311ada_parse_renaming (struct symbol *sym,
4312 const char **renamed_entity, int *len,
4313 const char **renaming_expr)
4314{
4315 enum ada_renaming_category kind;
4316 const char *info;
4317 const char *suffix;
4318
4319 if (sym == NULL)
4320 return ADA_NOT_RENAMING;
4321 switch (SYMBOL_CLASS (sym))
14f9c5c9 4322 {
aeb5907d
JB
4323 default:
4324 return ADA_NOT_RENAMING;
4325 case LOC_TYPEDEF:
4326 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4327 renamed_entity, len, renaming_expr);
4328 case LOC_LOCAL:
4329 case LOC_STATIC:
4330 case LOC_COMPUTED:
4331 case LOC_OPTIMIZED_OUT:
4332 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4333 if (info == NULL)
4334 return ADA_NOT_RENAMING;
4335 switch (info[5])
4336 {
4337 case '_':
4338 kind = ADA_OBJECT_RENAMING;
4339 info += 6;
4340 break;
4341 case 'E':
4342 kind = ADA_EXCEPTION_RENAMING;
4343 info += 7;
4344 break;
4345 case 'P':
4346 kind = ADA_PACKAGE_RENAMING;
4347 info += 7;
4348 break;
4349 case 'S':
4350 kind = ADA_SUBPROGRAM_RENAMING;
4351 info += 7;
4352 break;
4353 default:
4354 return ADA_NOT_RENAMING;
4355 }
14f9c5c9 4356 }
4c4b4cd2 4357
aeb5907d
JB
4358 if (renamed_entity != NULL)
4359 *renamed_entity = info;
4360 suffix = strstr (info, "___XE");
4361 if (suffix == NULL || suffix == info)
4362 return ADA_NOT_RENAMING;
4363 if (len != NULL)
4364 *len = strlen (info) - strlen (suffix);
4365 suffix += 5;
4366 if (renaming_expr != NULL)
4367 *renaming_expr = suffix;
4368 return kind;
4369}
4370
4371/* Assuming TYPE encodes a renaming according to the old encoding in
4372 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4373 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4374 ADA_NOT_RENAMING otherwise. */
4375static enum ada_renaming_category
4376parse_old_style_renaming (struct type *type,
4377 const char **renamed_entity, int *len,
4378 const char **renaming_expr)
4379{
4380 enum ada_renaming_category kind;
4381 const char *name;
4382 const char *info;
4383 const char *suffix;
14f9c5c9 4384
aeb5907d
JB
4385 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4386 || TYPE_NFIELDS (type) != 1)
4387 return ADA_NOT_RENAMING;
14f9c5c9 4388
a737d952 4389 name = TYPE_NAME (type);
aeb5907d
JB
4390 if (name == NULL)
4391 return ADA_NOT_RENAMING;
4392
4393 name = strstr (name, "___XR");
4394 if (name == NULL)
4395 return ADA_NOT_RENAMING;
4396 switch (name[5])
4397 {
4398 case '\0':
4399 case '_':
4400 kind = ADA_OBJECT_RENAMING;
4401 break;
4402 case 'E':
4403 kind = ADA_EXCEPTION_RENAMING;
4404 break;
4405 case 'P':
4406 kind = ADA_PACKAGE_RENAMING;
4407 break;
4408 case 'S':
4409 kind = ADA_SUBPROGRAM_RENAMING;
4410 break;
4411 default:
4412 return ADA_NOT_RENAMING;
4413 }
14f9c5c9 4414
aeb5907d
JB
4415 info = TYPE_FIELD_NAME (type, 0);
4416 if (info == NULL)
4417 return ADA_NOT_RENAMING;
4418 if (renamed_entity != NULL)
4419 *renamed_entity = info;
4420 suffix = strstr (info, "___XE");
4421 if (renaming_expr != NULL)
4422 *renaming_expr = suffix + 5;
4423 if (suffix == NULL || suffix == info)
4424 return ADA_NOT_RENAMING;
4425 if (len != NULL)
4426 *len = suffix - info;
4427 return kind;
a5ee536b
JB
4428}
4429
4430/* Compute the value of the given RENAMING_SYM, which is expected to
4431 be a symbol encoding a renaming expression. BLOCK is the block
4432 used to evaluate the renaming. */
52ce6436 4433
a5ee536b
JB
4434static struct value *
4435ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4436 const struct block *block)
a5ee536b 4437{
bbc13ae3 4438 const char *sym_name;
a5ee536b 4439
bbc13ae3 4440 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4441 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4442 return evaluate_expression (expr.get ());
a5ee536b 4443}
14f9c5c9 4444\f
d2e4a39e 4445
4c4b4cd2 4446 /* Evaluation: Function Calls */
14f9c5c9 4447
4c4b4cd2 4448/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4449 lvalues, and otherwise has the side-effect of allocating memory
4450 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4451
d2e4a39e 4452static struct value *
40bc484c 4453ensure_lval (struct value *val)
14f9c5c9 4454{
40bc484c
JB
4455 if (VALUE_LVAL (val) == not_lval
4456 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4457 {
df407dfe 4458 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4459 const CORE_ADDR addr =
4460 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4461
a84a8a0d 4462 VALUE_LVAL (val) = lval_memory;
1a088441 4463 set_value_address (val, addr);
40bc484c 4464 write_memory (addr, value_contents (val), len);
c3e5cd34 4465 }
14f9c5c9
AS
4466
4467 return val;
4468}
4469
4470/* Return the value ACTUAL, converted to be an appropriate value for a
4471 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4472 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4473 values not residing in memory, updating it as needed. */
14f9c5c9 4474
a93c0eb6 4475struct value *
40bc484c 4476ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4477{
df407dfe 4478 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4479 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4480 struct type *formal_target =
4481 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4482 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4483 struct type *actual_target =
4484 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4485 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4486
4c4b4cd2 4487 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4488 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4489 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4490 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4491 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4492 {
a84a8a0d 4493 struct value *result;
5b4ee69b 4494
14f9c5c9 4495 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4496 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4497 result = desc_data (actual);
cb923fcc 4498 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4499 {
4500 if (VALUE_LVAL (actual) != lval_memory)
4501 {
4502 struct value *val;
5b4ee69b 4503
df407dfe 4504 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4505 val = allocate_value (actual_type);
990a07ab 4506 memcpy ((char *) value_contents_raw (val),
0fd88904 4507 (char *) value_contents (actual),
4c4b4cd2 4508 TYPE_LENGTH (actual_type));
40bc484c 4509 actual = ensure_lval (val);
4c4b4cd2 4510 }
a84a8a0d 4511 result = value_addr (actual);
4c4b4cd2 4512 }
a84a8a0d
JB
4513 else
4514 return actual;
b1af9e97 4515 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4516 }
4517 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4518 return ada_value_ind (actual);
8344af1e
JB
4519 else if (ada_is_aligner_type (formal_type))
4520 {
4521 /* We need to turn this parameter into an aligner type
4522 as well. */
4523 struct value *aligner = allocate_value (formal_type);
4524 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4525
4526 value_assign_to_component (aligner, component, actual);
4527 return aligner;
4528 }
14f9c5c9
AS
4529
4530 return actual;
4531}
4532
438c98a1
JB
4533/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4534 type TYPE. This is usually an inefficient no-op except on some targets
4535 (such as AVR) where the representation of a pointer and an address
4536 differs. */
4537
4538static CORE_ADDR
4539value_pointer (struct value *value, struct type *type)
4540{
4541 struct gdbarch *gdbarch = get_type_arch (type);
4542 unsigned len = TYPE_LENGTH (type);
224c3ddb 4543 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4544 CORE_ADDR addr;
4545
4546 addr = value_address (value);
4547 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4548 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4549 return addr;
4550}
4551
14f9c5c9 4552
4c4b4cd2
PH
4553/* Push a descriptor of type TYPE for array value ARR on the stack at
4554 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4555 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4556 to-descriptor type rather than a descriptor type), a struct value *
4557 representing a pointer to this descriptor. */
14f9c5c9 4558
d2e4a39e 4559static struct value *
40bc484c 4560make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4561{
d2e4a39e
AS
4562 struct type *bounds_type = desc_bounds_type (type);
4563 struct type *desc_type = desc_base_type (type);
4564 struct value *descriptor = allocate_value (desc_type);
4565 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4566 int i;
d2e4a39e 4567
0963b4bd
MS
4568 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4569 i > 0; i -= 1)
14f9c5c9 4570 {
19f220c3
JK
4571 modify_field (value_type (bounds), value_contents_writeable (bounds),
4572 ada_array_bound (arr, i, 0),
4573 desc_bound_bitpos (bounds_type, i, 0),
4574 desc_bound_bitsize (bounds_type, i, 0));
4575 modify_field (value_type (bounds), value_contents_writeable (bounds),
4576 ada_array_bound (arr, i, 1),
4577 desc_bound_bitpos (bounds_type, i, 1),
4578 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4579 }
d2e4a39e 4580
40bc484c 4581 bounds = ensure_lval (bounds);
d2e4a39e 4582
19f220c3
JK
4583 modify_field (value_type (descriptor),
4584 value_contents_writeable (descriptor),
4585 value_pointer (ensure_lval (arr),
4586 TYPE_FIELD_TYPE (desc_type, 0)),
4587 fat_pntr_data_bitpos (desc_type),
4588 fat_pntr_data_bitsize (desc_type));
4589
4590 modify_field (value_type (descriptor),
4591 value_contents_writeable (descriptor),
4592 value_pointer (bounds,
4593 TYPE_FIELD_TYPE (desc_type, 1)),
4594 fat_pntr_bounds_bitpos (desc_type),
4595 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4596
40bc484c 4597 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4598
4599 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4600 return value_addr (descriptor);
4601 else
4602 return descriptor;
4603}
14f9c5c9 4604\f
3d9434b5
JB
4605 /* Symbol Cache Module */
4606
3d9434b5 4607/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4608 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4609 on the type of entity being printed, the cache can make it as much
4610 as an order of magnitude faster than without it.
4611
4612 The descriptive type DWARF extension has significantly reduced
4613 the need for this cache, at least when DWARF is being used. However,
4614 even in this case, some expensive name-based symbol searches are still
4615 sometimes necessary - to find an XVZ variable, mostly. */
4616
ee01b665 4617/* Initialize the contents of SYM_CACHE. */
3d9434b5 4618
ee01b665
JB
4619static void
4620ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4621{
4622 obstack_init (&sym_cache->cache_space);
4623 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4624}
3d9434b5 4625
ee01b665
JB
4626/* Free the memory used by SYM_CACHE. */
4627
4628static void
4629ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4630{
ee01b665
JB
4631 obstack_free (&sym_cache->cache_space, NULL);
4632 xfree (sym_cache);
4633}
3d9434b5 4634
ee01b665
JB
4635/* Return the symbol cache associated to the given program space PSPACE.
4636 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4637
ee01b665
JB
4638static struct ada_symbol_cache *
4639ada_get_symbol_cache (struct program_space *pspace)
4640{
4641 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4642
66c168ae 4643 if (pspace_data->sym_cache == NULL)
ee01b665 4644 {
66c168ae
JB
4645 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4646 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4647 }
4648
66c168ae 4649 return pspace_data->sym_cache;
ee01b665 4650}
3d9434b5
JB
4651
4652/* Clear all entries from the symbol cache. */
4653
4654static void
4655ada_clear_symbol_cache (void)
4656{
ee01b665
JB
4657 struct ada_symbol_cache *sym_cache
4658 = ada_get_symbol_cache (current_program_space);
4659
4660 obstack_free (&sym_cache->cache_space, NULL);
4661 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4662}
4663
fe978cb0 4664/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4665 Return it if found, or NULL otherwise. */
4666
4667static struct cache_entry **
fe978cb0 4668find_entry (const char *name, domain_enum domain)
3d9434b5 4669{
ee01b665
JB
4670 struct ada_symbol_cache *sym_cache
4671 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4672 int h = msymbol_hash (name) % HASH_SIZE;
4673 struct cache_entry **e;
4674
ee01b665 4675 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4676 {
fe978cb0 4677 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4678 return e;
4679 }
4680 return NULL;
4681}
4682
fe978cb0 4683/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4684 Return 1 if found, 0 otherwise.
4685
4686 If an entry was found and SYM is not NULL, set *SYM to the entry's
4687 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4688
96d887e8 4689static int
fe978cb0 4690lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4691 struct symbol **sym, const struct block **block)
96d887e8 4692{
fe978cb0 4693 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4694
4695 if (e == NULL)
4696 return 0;
4697 if (sym != NULL)
4698 *sym = (*e)->sym;
4699 if (block != NULL)
4700 *block = (*e)->block;
4701 return 1;
96d887e8
PH
4702}
4703
3d9434b5 4704/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4705 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4706
96d887e8 4707static void
fe978cb0 4708cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4709 const struct block *block)
96d887e8 4710{
ee01b665
JB
4711 struct ada_symbol_cache *sym_cache
4712 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4713 int h;
4714 char *copy;
4715 struct cache_entry *e;
4716
1994afbf
DE
4717 /* Symbols for builtin types don't have a block.
4718 For now don't cache such symbols. */
4719 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4720 return;
4721
3d9434b5
JB
4722 /* If the symbol is a local symbol, then do not cache it, as a search
4723 for that symbol depends on the context. To determine whether
4724 the symbol is local or not, we check the block where we found it
4725 against the global and static blocks of its associated symtab. */
4726 if (sym
08be3fe3 4727 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4728 GLOBAL_BLOCK) != block
08be3fe3 4729 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4730 STATIC_BLOCK) != block)
3d9434b5
JB
4731 return;
4732
4733 h = msymbol_hash (name) % HASH_SIZE;
e39db4db 4734 e = XOBNEW (&sym_cache->cache_space, cache_entry);
ee01b665
JB
4735 e->next = sym_cache->root[h];
4736 sym_cache->root[h] = e;
224c3ddb
SM
4737 e->name = copy
4738 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4739 strcpy (copy, name);
4740 e->sym = sym;
fe978cb0 4741 e->domain = domain;
3d9434b5 4742 e->block = block;
96d887e8 4743}
4c4b4cd2
PH
4744\f
4745 /* Symbol Lookup */
4746
b5ec771e
PA
4747/* Return the symbol name match type that should be used used when
4748 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4749
4750 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4751 for Ada lookups. */
c0431670 4752
b5ec771e
PA
4753static symbol_name_match_type
4754name_match_type_from_name (const char *lookup_name)
c0431670 4755{
b5ec771e
PA
4756 return (strstr (lookup_name, "__") == NULL
4757 ? symbol_name_match_type::WILD
4758 : symbol_name_match_type::FULL);
c0431670
JB
4759}
4760
4c4b4cd2
PH
4761/* Return the result of a standard (literal, C-like) lookup of NAME in
4762 given DOMAIN, visible from lexical block BLOCK. */
4763
4764static struct symbol *
4765standard_lookup (const char *name, const struct block *block,
4766 domain_enum domain)
4767{
acbd605d 4768 /* Initialize it just to avoid a GCC false warning. */
6640a367 4769 struct block_symbol sym = {};
4c4b4cd2 4770
d12307c1
PMR
4771 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4772 return sym.symbol;
a2cd4f14 4773 ada_lookup_encoded_symbol (name, block, domain, &sym);
d12307c1
PMR
4774 cache_symbol (name, domain, sym.symbol, sym.block);
4775 return sym.symbol;
4c4b4cd2
PH
4776}
4777
4778
4779/* Non-zero iff there is at least one non-function/non-enumeral symbol
4780 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4781 since they contend in overloading in the same way. */
4782static int
d12307c1 4783is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4784{
4785 int i;
4786
4787 for (i = 0; i < n; i += 1)
d12307c1
PMR
4788 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4789 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4790 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4791 return 1;
4792
4793 return 0;
4794}
4795
4796/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4797 struct types. Otherwise, they may not. */
14f9c5c9
AS
4798
4799static int
d2e4a39e 4800equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4801{
d2e4a39e 4802 if (type0 == type1)
14f9c5c9 4803 return 1;
d2e4a39e 4804 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4805 || TYPE_CODE (type0) != TYPE_CODE (type1))
4806 return 0;
d2e4a39e 4807 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4808 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4809 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4810 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4811 return 1;
d2e4a39e 4812
14f9c5c9
AS
4813 return 0;
4814}
4815
4816/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4817 no more defined than that of SYM1. */
14f9c5c9
AS
4818
4819static int
d2e4a39e 4820lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4821{
4822 if (sym0 == sym1)
4823 return 1;
176620f1 4824 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4825 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4826 return 0;
4827
d2e4a39e 4828 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4829 {
4830 case LOC_UNDEF:
4831 return 1;
4832 case LOC_TYPEDEF:
4833 {
4c4b4cd2
PH
4834 struct type *type0 = SYMBOL_TYPE (sym0);
4835 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4836 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4837 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4838 int len0 = strlen (name0);
5b4ee69b 4839
4c4b4cd2
PH
4840 return
4841 TYPE_CODE (type0) == TYPE_CODE (type1)
4842 && (equiv_types (type0, type1)
4843 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4844 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4845 }
4846 case LOC_CONST:
4847 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4848 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4849 default:
4850 return 0;
14f9c5c9
AS
4851 }
4852}
4853
d12307c1 4854/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4855 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4856
4857static void
76a01679
JB
4858add_defn_to_vec (struct obstack *obstackp,
4859 struct symbol *sym,
f0c5f9b2 4860 const struct block *block)
14f9c5c9
AS
4861{
4862 int i;
d12307c1 4863 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4864
529cad9c
PH
4865 /* Do not try to complete stub types, as the debugger is probably
4866 already scanning all symbols matching a certain name at the
4867 time when this function is called. Trying to replace the stub
4868 type by its associated full type will cause us to restart a scan
4869 which may lead to an infinite recursion. Instead, the client
4870 collecting the matching symbols will end up collecting several
4871 matches, with at least one of them complete. It can then filter
4872 out the stub ones if needed. */
4873
4c4b4cd2
PH
4874 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4875 {
d12307c1 4876 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4877 return;
d12307c1 4878 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4879 {
d12307c1 4880 prevDefns[i].symbol = sym;
4c4b4cd2 4881 prevDefns[i].block = block;
4c4b4cd2 4882 return;
76a01679 4883 }
4c4b4cd2
PH
4884 }
4885
4886 {
d12307c1 4887 struct block_symbol info;
4c4b4cd2 4888
d12307c1 4889 info.symbol = sym;
4c4b4cd2 4890 info.block = block;
d12307c1 4891 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4892 }
4893}
4894
d12307c1
PMR
4895/* Number of block_symbol structures currently collected in current vector in
4896 OBSTACKP. */
4c4b4cd2 4897
76a01679
JB
4898static int
4899num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4900{
d12307c1 4901 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4902}
4903
d12307c1
PMR
4904/* Vector of block_symbol structures currently collected in current vector in
4905 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4906
d12307c1 4907static struct block_symbol *
4c4b4cd2
PH
4908defns_collected (struct obstack *obstackp, int finish)
4909{
4910 if (finish)
224c3ddb 4911 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4912 else
d12307c1 4913 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4914}
4915
7c7b6655
TT
4916/* Return a bound minimal symbol matching NAME according to Ada
4917 decoding rules. Returns an invalid symbol if there is no such
4918 minimal symbol. Names prefixed with "standard__" are handled
4919 specially: "standard__" is first stripped off, and only static and
4920 global symbols are searched. */
4c4b4cd2 4921
7c7b6655 4922struct bound_minimal_symbol
96d887e8 4923ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4924{
7c7b6655 4925 struct bound_minimal_symbol result;
4c4b4cd2 4926
7c7b6655
TT
4927 memset (&result, 0, sizeof (result));
4928
b5ec771e
PA
4929 symbol_name_match_type match_type = name_match_type_from_name (name);
4930 lookup_name_info lookup_name (name, match_type);
4931
4932 symbol_name_matcher_ftype *match_name
4933 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4934
2030c079 4935 for (objfile *objfile : current_program_space->objfiles ())
5325b9bf 4936 {
7932255d 4937 for (minimal_symbol *msymbol : objfile->msymbols ())
5325b9bf
TT
4938 {
4939 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4940 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4941 {
4942 result.minsym = msymbol;
4943 result.objfile = objfile;
4944 break;
4945 }
4946 }
4947 }
4c4b4cd2 4948
7c7b6655 4949 return result;
96d887e8 4950}
4c4b4cd2 4951
96d887e8
PH
4952/* For all subprograms that statically enclose the subprogram of the
4953 selected frame, add symbols matching identifier NAME in DOMAIN
4954 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4955 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4956 with a wildcard prefix. */
4c4b4cd2 4957
96d887e8
PH
4958static void
4959add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4960 const lookup_name_info &lookup_name,
4961 domain_enum domain)
96d887e8 4962{
96d887e8 4963}
14f9c5c9 4964
96d887e8
PH
4965/* True if TYPE is definitely an artificial type supplied to a symbol
4966 for which no debugging information was given in the symbol file. */
14f9c5c9 4967
96d887e8
PH
4968static int
4969is_nondebugging_type (struct type *type)
4970{
0d5cff50 4971 const char *name = ada_type_name (type);
5b4ee69b 4972
96d887e8
PH
4973 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4974}
4c4b4cd2 4975
8f17729f
JB
4976/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4977 that are deemed "identical" for practical purposes.
4978
4979 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4980 types and that their number of enumerals is identical (in other
4981 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4982
4983static int
4984ada_identical_enum_types_p (struct type *type1, struct type *type2)
4985{
4986 int i;
4987
4988 /* The heuristic we use here is fairly conservative. We consider
4989 that 2 enumerate types are identical if they have the same
4990 number of enumerals and that all enumerals have the same
4991 underlying value and name. */
4992
4993 /* All enums in the type should have an identical underlying value. */
4994 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4995 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4996 return 0;
4997
4998 /* All enumerals should also have the same name (modulo any numerical
4999 suffix). */
5000 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5001 {
0d5cff50
DE
5002 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5003 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5004 int len_1 = strlen (name_1);
5005 int len_2 = strlen (name_2);
5006
5007 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5008 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5009 if (len_1 != len_2
5010 || strncmp (TYPE_FIELD_NAME (type1, i),
5011 TYPE_FIELD_NAME (type2, i),
5012 len_1) != 0)
5013 return 0;
5014 }
5015
5016 return 1;
5017}
5018
5019/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5020 that are deemed "identical" for practical purposes. Sometimes,
5021 enumerals are not strictly identical, but their types are so similar
5022 that they can be considered identical.
5023
5024 For instance, consider the following code:
5025
5026 type Color is (Black, Red, Green, Blue, White);
5027 type RGB_Color is new Color range Red .. Blue;
5028
5029 Type RGB_Color is a subrange of an implicit type which is a copy
5030 of type Color. If we call that implicit type RGB_ColorB ("B" is
5031 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5032 As a result, when an expression references any of the enumeral
5033 by name (Eg. "print green"), the expression is technically
5034 ambiguous and the user should be asked to disambiguate. But
5035 doing so would only hinder the user, since it wouldn't matter
5036 what choice he makes, the outcome would always be the same.
5037 So, for practical purposes, we consider them as the same. */
5038
5039static int
54d343a2 5040symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
5041{
5042 int i;
5043
5044 /* Before performing a thorough comparison check of each type,
5045 we perform a series of inexpensive checks. We expect that these
5046 checks will quickly fail in the vast majority of cases, and thus
5047 help prevent the unnecessary use of a more expensive comparison.
5048 Said comparison also expects us to make some of these checks
5049 (see ada_identical_enum_types_p). */
5050
5051 /* Quick check: All symbols should have an enum type. */
54d343a2 5052 for (i = 0; i < syms.size (); i++)
d12307c1 5053 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5054 return 0;
5055
5056 /* Quick check: They should all have the same value. */
54d343a2 5057 for (i = 1; i < syms.size (); i++)
d12307c1 5058 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5059 return 0;
5060
5061 /* Quick check: They should all have the same number of enumerals. */
54d343a2 5062 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5063 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5064 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5065 return 0;
5066
5067 /* All the sanity checks passed, so we might have a set of
5068 identical enumeration types. Perform a more complete
5069 comparison of the type of each symbol. */
54d343a2 5070 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5071 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5072 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5073 return 0;
5074
5075 return 1;
5076}
5077
54d343a2 5078/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
5079 duplicate other symbols in the list (The only case I know of where
5080 this happens is when object files containing stabs-in-ecoff are
5081 linked with files containing ordinary ecoff debugging symbols (or no
5082 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5083 Returns the number of items in the modified list. */
4c4b4cd2 5084
96d887e8 5085static int
54d343a2 5086remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5087{
5088 int i, j;
4c4b4cd2 5089
8f17729f
JB
5090 /* We should never be called with less than 2 symbols, as there
5091 cannot be any extra symbol in that case. But it's easy to
5092 handle, since we have nothing to do in that case. */
54d343a2
TT
5093 if (syms->size () < 2)
5094 return syms->size ();
8f17729f 5095
96d887e8 5096 i = 0;
54d343a2 5097 while (i < syms->size ())
96d887e8 5098 {
a35ddb44 5099 int remove_p = 0;
339c13b6
JB
5100
5101 /* If two symbols have the same name and one of them is a stub type,
5102 the get rid of the stub. */
5103
54d343a2
TT
5104 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5105 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5106 {
54d343a2 5107 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5108 {
5109 if (j != i
54d343a2
TT
5110 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5111 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5112 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5113 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5114 remove_p = 1;
339c13b6
JB
5115 }
5116 }
5117
5118 /* Two symbols with the same name, same class and same address
5119 should be identical. */
5120
54d343a2
TT
5121 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5122 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5123 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5124 {
54d343a2 5125 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5126 {
5127 if (i != j
54d343a2
TT
5128 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5129 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5130 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5131 && SYMBOL_CLASS ((*syms)[i].symbol)
5132 == SYMBOL_CLASS ((*syms)[j].symbol)
5133 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5134 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5135 remove_p = 1;
4c4b4cd2 5136 }
4c4b4cd2 5137 }
339c13b6 5138
a35ddb44 5139 if (remove_p)
54d343a2 5140 syms->erase (syms->begin () + i);
339c13b6 5141
96d887e8 5142 i += 1;
14f9c5c9 5143 }
8f17729f
JB
5144
5145 /* If all the remaining symbols are identical enumerals, then
5146 just keep the first one and discard the rest.
5147
5148 Unlike what we did previously, we do not discard any entry
5149 unless they are ALL identical. This is because the symbol
5150 comparison is not a strict comparison, but rather a practical
5151 comparison. If all symbols are considered identical, then
5152 we can just go ahead and use the first one and discard the rest.
5153 But if we cannot reduce the list to a single element, we have
5154 to ask the user to disambiguate anyways. And if we have to
5155 present a multiple-choice menu, it's less confusing if the list
5156 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5157 if (symbols_are_identical_enums (*syms))
5158 syms->resize (1);
8f17729f 5159
54d343a2 5160 return syms->size ();
14f9c5c9
AS
5161}
5162
96d887e8
PH
5163/* Given a type that corresponds to a renaming entity, use the type name
5164 to extract the scope (package name or function name, fully qualified,
5165 and following the GNAT encoding convention) where this renaming has been
49d83361 5166 defined. */
4c4b4cd2 5167
49d83361 5168static std::string
96d887e8 5169xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5170{
96d887e8 5171 /* The renaming types adhere to the following convention:
0963b4bd 5172 <scope>__<rename>___<XR extension>.
96d887e8
PH
5173 So, to extract the scope, we search for the "___XR" extension,
5174 and then backtrack until we find the first "__". */
76a01679 5175
a737d952 5176 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5177 const char *suffix = strstr (name, "___XR");
5178 const char *last;
14f9c5c9 5179
96d887e8
PH
5180 /* Now, backtrack a bit until we find the first "__". Start looking
5181 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5182
96d887e8
PH
5183 for (last = suffix - 3; last > name; last--)
5184 if (last[0] == '_' && last[1] == '_')
5185 break;
76a01679 5186
96d887e8 5187 /* Make a copy of scope and return it. */
49d83361 5188 return std::string (name, last);
4c4b4cd2
PH
5189}
5190
96d887e8 5191/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5192
96d887e8
PH
5193static int
5194is_package_name (const char *name)
4c4b4cd2 5195{
96d887e8
PH
5196 /* Here, We take advantage of the fact that no symbols are generated
5197 for packages, while symbols are generated for each function.
5198 So the condition for NAME represent a package becomes equivalent
5199 to NAME not existing in our list of symbols. There is only one
5200 small complication with library-level functions (see below). */
4c4b4cd2 5201
96d887e8
PH
5202 /* If it is a function that has not been defined at library level,
5203 then we should be able to look it up in the symbols. */
5204 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5205 return 0;
14f9c5c9 5206
96d887e8
PH
5207 /* Library-level function names start with "_ada_". See if function
5208 "_ada_" followed by NAME can be found. */
14f9c5c9 5209
96d887e8 5210 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5211 functions names cannot contain "__" in them. */
96d887e8
PH
5212 if (strstr (name, "__") != NULL)
5213 return 0;
4c4b4cd2 5214
528e1572 5215 std::string fun_name = string_printf ("_ada_%s", name);
14f9c5c9 5216
528e1572 5217 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
96d887e8 5218}
14f9c5c9 5219
96d887e8 5220/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5221 not visible from FUNCTION_NAME. */
14f9c5c9 5222
96d887e8 5223static int
0d5cff50 5224old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5225{
aeb5907d
JB
5226 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5227 return 0;
5228
49d83361 5229 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5230
96d887e8 5231 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5232 if (is_package_name (scope.c_str ()))
5233 return 0;
14f9c5c9 5234
96d887e8
PH
5235 /* Check that the rename is in the current function scope by checking
5236 that its name starts with SCOPE. */
76a01679 5237
96d887e8
PH
5238 /* If the function name starts with "_ada_", it means that it is
5239 a library-level function. Strip this prefix before doing the
5240 comparison, as the encoding for the renaming does not contain
5241 this prefix. */
61012eef 5242 if (startswith (function_name, "_ada_"))
96d887e8 5243 function_name += 5;
f26caa11 5244
49d83361 5245 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5246}
5247
aeb5907d
JB
5248/* Remove entries from SYMS that corresponds to a renaming entity that
5249 is not visible from the function associated with CURRENT_BLOCK or
5250 that is superfluous due to the presence of more specific renaming
5251 information. Places surviving symbols in the initial entries of
5252 SYMS and returns the number of surviving symbols.
96d887e8
PH
5253
5254 Rationale:
aeb5907d
JB
5255 First, in cases where an object renaming is implemented as a
5256 reference variable, GNAT may produce both the actual reference
5257 variable and the renaming encoding. In this case, we discard the
5258 latter.
5259
5260 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5261 entity. Unfortunately, STABS currently does not support the definition
5262 of types that are local to a given lexical block, so all renamings types
5263 are emitted at library level. As a consequence, if an application
5264 contains two renaming entities using the same name, and a user tries to
5265 print the value of one of these entities, the result of the ada symbol
5266 lookup will also contain the wrong renaming type.
f26caa11 5267
96d887e8
PH
5268 This function partially covers for this limitation by attempting to
5269 remove from the SYMS list renaming symbols that should be visible
5270 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5271 method with the current information available. The implementation
5272 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5273
5274 - When the user tries to print a rename in a function while there
5275 is another rename entity defined in a package: Normally, the
5276 rename in the function has precedence over the rename in the
5277 package, so the latter should be removed from the list. This is
5278 currently not the case.
5279
5280 - This function will incorrectly remove valid renames if
5281 the CURRENT_BLOCK corresponds to a function which symbol name
5282 has been changed by an "Export" pragma. As a consequence,
5283 the user will be unable to print such rename entities. */
4c4b4cd2 5284
14f9c5c9 5285static int
54d343a2
TT
5286remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5287 const struct block *current_block)
4c4b4cd2
PH
5288{
5289 struct symbol *current_function;
0d5cff50 5290 const char *current_function_name;
4c4b4cd2 5291 int i;
aeb5907d
JB
5292 int is_new_style_renaming;
5293
5294 /* If there is both a renaming foo___XR... encoded as a variable and
5295 a simple variable foo in the same block, discard the latter.
0963b4bd 5296 First, zero out such symbols, then compress. */
aeb5907d 5297 is_new_style_renaming = 0;
54d343a2 5298 for (i = 0; i < syms->size (); i += 1)
aeb5907d 5299 {
54d343a2
TT
5300 struct symbol *sym = (*syms)[i].symbol;
5301 const struct block *block = (*syms)[i].block;
aeb5907d
JB
5302 const char *name;
5303 const char *suffix;
5304
5305 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5306 continue;
5307 name = SYMBOL_LINKAGE_NAME (sym);
5308 suffix = strstr (name, "___XR");
5309
5310 if (suffix != NULL)
5311 {
5312 int name_len = suffix - name;
5313 int j;
5b4ee69b 5314
aeb5907d 5315 is_new_style_renaming = 1;
54d343a2
TT
5316 for (j = 0; j < syms->size (); j += 1)
5317 if (i != j && (*syms)[j].symbol != NULL
5318 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
aeb5907d 5319 name_len) == 0
54d343a2
TT
5320 && block == (*syms)[j].block)
5321 (*syms)[j].symbol = NULL;
aeb5907d
JB
5322 }
5323 }
5324 if (is_new_style_renaming)
5325 {
5326 int j, k;
5327
54d343a2
TT
5328 for (j = k = 0; j < syms->size (); j += 1)
5329 if ((*syms)[j].symbol != NULL)
aeb5907d 5330 {
54d343a2 5331 (*syms)[k] = (*syms)[j];
aeb5907d
JB
5332 k += 1;
5333 }
5334 return k;
5335 }
4c4b4cd2
PH
5336
5337 /* Extract the function name associated to CURRENT_BLOCK.
5338 Abort if unable to do so. */
76a01679 5339
4c4b4cd2 5340 if (current_block == NULL)
54d343a2 5341 return syms->size ();
76a01679 5342
7f0df278 5343 current_function = block_linkage_function (current_block);
4c4b4cd2 5344 if (current_function == NULL)
54d343a2 5345 return syms->size ();
4c4b4cd2
PH
5346
5347 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5348 if (current_function_name == NULL)
54d343a2 5349 return syms->size ();
4c4b4cd2
PH
5350
5351 /* Check each of the symbols, and remove it from the list if it is
5352 a type corresponding to a renaming that is out of the scope of
5353 the current block. */
5354
5355 i = 0;
54d343a2 5356 while (i < syms->size ())
4c4b4cd2 5357 {
54d343a2 5358 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
aeb5907d 5359 == ADA_OBJECT_RENAMING
54d343a2
TT
5360 && old_renaming_is_invisible ((*syms)[i].symbol,
5361 current_function_name))
5362 syms->erase (syms->begin () + i);
4c4b4cd2
PH
5363 else
5364 i += 1;
5365 }
5366
54d343a2 5367 return syms->size ();
4c4b4cd2
PH
5368}
5369
339c13b6
JB
5370/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5371 whose name and domain match NAME and DOMAIN respectively.
5372 If no match was found, then extend the search to "enclosing"
5373 routines (in other words, if we're inside a nested function,
5374 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5375 If WILD_MATCH_P is nonzero, perform the naming matching in
5376 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5377
5378 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5379
5380static void
b5ec771e
PA
5381ada_add_local_symbols (struct obstack *obstackp,
5382 const lookup_name_info &lookup_name,
5383 const struct block *block, domain_enum domain)
339c13b6
JB
5384{
5385 int block_depth = 0;
5386
5387 while (block != NULL)
5388 {
5389 block_depth += 1;
b5ec771e 5390 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5391
5392 /* If we found a non-function match, assume that's the one. */
5393 if (is_nonfunction (defns_collected (obstackp, 0),
5394 num_defns_collected (obstackp)))
5395 return;
5396
5397 block = BLOCK_SUPERBLOCK (block);
5398 }
5399
5400 /* If no luck so far, try to find NAME as a local symbol in some lexically
5401 enclosing subprogram. */
5402 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5403 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5404}
5405
ccefe4c4 5406/* An object of this type is used as the user_data argument when
40658b94 5407 calling the map_matching_symbols method. */
ccefe4c4 5408
40658b94 5409struct match_data
ccefe4c4 5410{
40658b94 5411 struct objfile *objfile;
ccefe4c4 5412 struct obstack *obstackp;
40658b94
PH
5413 struct symbol *arg_sym;
5414 int found_sym;
ccefe4c4
TT
5415};
5416
22cee43f 5417/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5418 to a list of symbols. DATA0 is a pointer to a struct match_data *
5419 containing the obstack that collects the symbol list, the file that SYM
5420 must come from, a flag indicating whether a non-argument symbol has
5421 been found in the current block, and the last argument symbol
5422 passed in SYM within the current block (if any). When SYM is null,
5423 marking the end of a block, the argument symbol is added if no
5424 other has been found. */
ccefe4c4 5425
40658b94 5426static int
582942f4
TT
5427aux_add_nonlocal_symbols (const struct block *block, struct symbol *sym,
5428 void *data0)
ccefe4c4 5429{
40658b94
PH
5430 struct match_data *data = (struct match_data *) data0;
5431
5432 if (sym == NULL)
5433 {
5434 if (!data->found_sym && data->arg_sym != NULL)
5435 add_defn_to_vec (data->obstackp,
5436 fixup_symbol_section (data->arg_sym, data->objfile),
5437 block);
5438 data->found_sym = 0;
5439 data->arg_sym = NULL;
5440 }
5441 else
5442 {
5443 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5444 return 0;
5445 else if (SYMBOL_IS_ARGUMENT (sym))
5446 data->arg_sym = sym;
5447 else
5448 {
5449 data->found_sym = 1;
5450 add_defn_to_vec (data->obstackp,
5451 fixup_symbol_section (sym, data->objfile),
5452 block);
5453 }
5454 }
5455 return 0;
5456}
5457
b5ec771e
PA
5458/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5459 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5460 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5461
5462static int
5463ada_add_block_renamings (struct obstack *obstackp,
5464 const struct block *block,
b5ec771e
PA
5465 const lookup_name_info &lookup_name,
5466 domain_enum domain)
22cee43f
PMR
5467{
5468 struct using_direct *renaming;
5469 int defns_mark = num_defns_collected (obstackp);
5470
b5ec771e
PA
5471 symbol_name_matcher_ftype *name_match
5472 = ada_get_symbol_name_matcher (lookup_name);
5473
22cee43f
PMR
5474 for (renaming = block_using (block);
5475 renaming != NULL;
5476 renaming = renaming->next)
5477 {
5478 const char *r_name;
22cee43f
PMR
5479
5480 /* Avoid infinite recursions: skip this renaming if we are actually
5481 already traversing it.
5482
5483 Currently, symbol lookup in Ada don't use the namespace machinery from
5484 C++/Fortran support: skip namespace imports that use them. */
5485 if (renaming->searched
5486 || (renaming->import_src != NULL
5487 && renaming->import_src[0] != '\0')
5488 || (renaming->import_dest != NULL
5489 && renaming->import_dest[0] != '\0'))
5490 continue;
5491 renaming->searched = 1;
5492
5493 /* TODO: here, we perform another name-based symbol lookup, which can
5494 pull its own multiple overloads. In theory, we should be able to do
5495 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5496 not a simple name. But in order to do this, we would need to enhance
5497 the DWARF reader to associate a symbol to this renaming, instead of a
5498 name. So, for now, we do something simpler: re-use the C++/Fortran
5499 namespace machinery. */
5500 r_name = (renaming->alias != NULL
5501 ? renaming->alias
5502 : renaming->declaration);
b5ec771e
PA
5503 if (name_match (r_name, lookup_name, NULL))
5504 {
5505 lookup_name_info decl_lookup_name (renaming->declaration,
5506 lookup_name.match_type ());
5507 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5508 1, NULL);
5509 }
22cee43f
PMR
5510 renaming->searched = 0;
5511 }
5512 return num_defns_collected (obstackp) != defns_mark;
5513}
5514
db230ce3
JB
5515/* Implements compare_names, but only applying the comparision using
5516 the given CASING. */
5b4ee69b 5517
40658b94 5518static int
db230ce3
JB
5519compare_names_with_case (const char *string1, const char *string2,
5520 enum case_sensitivity casing)
40658b94
PH
5521{
5522 while (*string1 != '\0' && *string2 != '\0')
5523 {
db230ce3
JB
5524 char c1, c2;
5525
40658b94
PH
5526 if (isspace (*string1) || isspace (*string2))
5527 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5528
5529 if (casing == case_sensitive_off)
5530 {
5531 c1 = tolower (*string1);
5532 c2 = tolower (*string2);
5533 }
5534 else
5535 {
5536 c1 = *string1;
5537 c2 = *string2;
5538 }
5539 if (c1 != c2)
40658b94 5540 break;
db230ce3 5541
40658b94
PH
5542 string1 += 1;
5543 string2 += 1;
5544 }
db230ce3 5545
40658b94
PH
5546 switch (*string1)
5547 {
5548 case '(':
5549 return strcmp_iw_ordered (string1, string2);
5550 case '_':
5551 if (*string2 == '\0')
5552 {
052874e8 5553 if (is_name_suffix (string1))
40658b94
PH
5554 return 0;
5555 else
1a1d5513 5556 return 1;
40658b94 5557 }
dbb8534f 5558 /* FALLTHROUGH */
40658b94
PH
5559 default:
5560 if (*string2 == '(')
5561 return strcmp_iw_ordered (string1, string2);
5562 else
db230ce3
JB
5563 {
5564 if (casing == case_sensitive_off)
5565 return tolower (*string1) - tolower (*string2);
5566 else
5567 return *string1 - *string2;
5568 }
40658b94 5569 }
ccefe4c4
TT
5570}
5571
db230ce3
JB
5572/* Compare STRING1 to STRING2, with results as for strcmp.
5573 Compatible with strcmp_iw_ordered in that...
5574
5575 strcmp_iw_ordered (STRING1, STRING2) <= 0
5576
5577 ... implies...
5578
5579 compare_names (STRING1, STRING2) <= 0
5580
5581 (they may differ as to what symbols compare equal). */
5582
5583static int
5584compare_names (const char *string1, const char *string2)
5585{
5586 int result;
5587
5588 /* Similar to what strcmp_iw_ordered does, we need to perform
5589 a case-insensitive comparison first, and only resort to
5590 a second, case-sensitive, comparison if the first one was
5591 not sufficient to differentiate the two strings. */
5592
5593 result = compare_names_with_case (string1, string2, case_sensitive_off);
5594 if (result == 0)
5595 result = compare_names_with_case (string1, string2, case_sensitive_on);
5596
5597 return result;
5598}
5599
b5ec771e
PA
5600/* Convenience function to get at the Ada encoded lookup name for
5601 LOOKUP_NAME, as a C string. */
5602
5603static const char *
5604ada_lookup_name (const lookup_name_info &lookup_name)
5605{
5606 return lookup_name.ada ().lookup_name ().c_str ();
5607}
5608
339c13b6 5609/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5610 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5611 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5612 symbols otherwise. */
339c13b6
JB
5613
5614static void
b5ec771e
PA
5615add_nonlocal_symbols (struct obstack *obstackp,
5616 const lookup_name_info &lookup_name,
5617 domain_enum domain, int global)
339c13b6 5618{
40658b94 5619 struct match_data data;
339c13b6 5620
6475f2fe 5621 memset (&data, 0, sizeof data);
ccefe4c4 5622 data.obstackp = obstackp;
339c13b6 5623
b5ec771e
PA
5624 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5625
2030c079 5626 for (objfile *objfile : current_program_space->objfiles ())
40658b94
PH
5627 {
5628 data.objfile = objfile;
5629
5630 if (is_wild_match)
b5ec771e
PA
5631 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5632 domain, global,
4186eb54 5633 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5634 symbol_name_match_type::WILD,
5635 NULL);
40658b94 5636 else
b5ec771e
PA
5637 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5638 domain, global,
4186eb54 5639 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5640 symbol_name_match_type::FULL,
5641 compare_names);
22cee43f 5642
b669c953 5643 for (compunit_symtab *cu : objfile->compunits ())
22cee43f
PMR
5644 {
5645 const struct block *global_block
5646 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5647
b5ec771e
PA
5648 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5649 domain))
22cee43f
PMR
5650 data.found_sym = 1;
5651 }
40658b94
PH
5652 }
5653
5654 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5655 {
b5ec771e
PA
5656 const char *name = ada_lookup_name (lookup_name);
5657 std::string name1 = std::string ("<_ada_") + name + '>';
5658
2030c079 5659 for (objfile *objfile : current_program_space->objfiles ())
40658b94 5660 {
40658b94 5661 data.objfile = objfile;
b5ec771e
PA
5662 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5663 domain, global,
0963b4bd
MS
5664 aux_add_nonlocal_symbols,
5665 &data,
b5ec771e
PA
5666 symbol_name_match_type::FULL,
5667 compare_names);
40658b94
PH
5668 }
5669 }
339c13b6
JB
5670}
5671
b5ec771e
PA
5672/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5673 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5674 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5675
22cee43f
PMR
5676 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5677 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5678 is the one match returned (no other matches in that or
d9680e73 5679 enclosing blocks is returned). If there are any matches in or
22cee43f 5680 surrounding BLOCK, then these alone are returned.
4eeaa230 5681
b5ec771e
PA
5682 Names prefixed with "standard__" are handled specially:
5683 "standard__" is first stripped off (by the lookup_name
5684 constructor), and only static and global symbols are searched.
14f9c5c9 5685
22cee43f
PMR
5686 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5687 to lookup global symbols. */
5688
5689static void
5690ada_add_all_symbols (struct obstack *obstackp,
5691 const struct block *block,
b5ec771e 5692 const lookup_name_info &lookup_name,
22cee43f
PMR
5693 domain_enum domain,
5694 int full_search,
5695 int *made_global_lookup_p)
14f9c5c9
AS
5696{
5697 struct symbol *sym;
14f9c5c9 5698
22cee43f
PMR
5699 if (made_global_lookup_p)
5700 *made_global_lookup_p = 0;
339c13b6
JB
5701
5702 /* Special case: If the user specifies a symbol name inside package
5703 Standard, do a non-wild matching of the symbol name without
5704 the "standard__" prefix. This was primarily introduced in order
5705 to allow the user to specifically access the standard exceptions
5706 using, for instance, Standard.Constraint_Error when Constraint_Error
5707 is ambiguous (due to the user defining its own Constraint_Error
5708 entity inside its program). */
b5ec771e
PA
5709 if (lookup_name.ada ().standard_p ())
5710 block = NULL;
4c4b4cd2 5711
339c13b6 5712 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5713
4eeaa230
DE
5714 if (block != NULL)
5715 {
5716 if (full_search)
b5ec771e 5717 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5718 else
5719 {
5720 /* In the !full_search case we're are being called by
5721 ada_iterate_over_symbols, and we don't want to search
5722 superblocks. */
b5ec771e 5723 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5724 }
22cee43f
PMR
5725 if (num_defns_collected (obstackp) > 0 || !full_search)
5726 return;
4eeaa230 5727 }
d2e4a39e 5728
339c13b6
JB
5729 /* No non-global symbols found. Check our cache to see if we have
5730 already performed this search before. If we have, then return
5731 the same result. */
5732
b5ec771e
PA
5733 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5734 domain, &sym, &block))
4c4b4cd2
PH
5735 {
5736 if (sym != NULL)
b5ec771e 5737 add_defn_to_vec (obstackp, sym, block);
22cee43f 5738 return;
4c4b4cd2 5739 }
14f9c5c9 5740
22cee43f
PMR
5741 if (made_global_lookup_p)
5742 *made_global_lookup_p = 1;
b1eedac9 5743
339c13b6
JB
5744 /* Search symbols from all global blocks. */
5745
b5ec771e 5746 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5747
4c4b4cd2 5748 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5749 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5750
22cee43f 5751 if (num_defns_collected (obstackp) == 0)
b5ec771e 5752 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5753}
5754
b5ec771e
PA
5755/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5756 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5757 matches.
54d343a2
TT
5758 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5759 found and the blocks and symbol tables (if any) in which they were
5760 found.
22cee43f
PMR
5761
5762 When full_search is non-zero, any non-function/non-enumeral
5763 symbol match within the nest of blocks whose innermost member is BLOCK,
5764 is the one match returned (no other matches in that or
5765 enclosing blocks is returned). If there are any matches in or
5766 surrounding BLOCK, then these alone are returned.
5767
5768 Names prefixed with "standard__" are handled specially: "standard__"
5769 is first stripped off, and only static and global symbols are searched. */
5770
5771static int
b5ec771e
PA
5772ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5773 const struct block *block,
22cee43f 5774 domain_enum domain,
54d343a2 5775 std::vector<struct block_symbol> *results,
22cee43f
PMR
5776 int full_search)
5777{
22cee43f
PMR
5778 int syms_from_global_search;
5779 int ndefns;
ec6a20c2 5780 auto_obstack obstack;
22cee43f 5781
ec6a20c2 5782 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5783 domain, full_search, &syms_from_global_search);
14f9c5c9 5784
ec6a20c2
JB
5785 ndefns = num_defns_collected (&obstack);
5786
54d343a2
TT
5787 struct block_symbol *base = defns_collected (&obstack, 1);
5788 for (int i = 0; i < ndefns; ++i)
5789 results->push_back (base[i]);
4c4b4cd2 5790
54d343a2 5791 ndefns = remove_extra_symbols (results);
4c4b4cd2 5792
b1eedac9 5793 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5794 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5795
b1eedac9 5796 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5797 cache_symbol (ada_lookup_name (lookup_name), domain,
5798 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5799
54d343a2 5800 ndefns = remove_irrelevant_renamings (results, block);
ec6a20c2 5801
14f9c5c9
AS
5802 return ndefns;
5803}
5804
b5ec771e 5805/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
54d343a2
TT
5806 in global scopes, returning the number of matches, and filling *RESULTS
5807 with (SYM,BLOCK) tuples.
ec6a20c2 5808
4eeaa230
DE
5809 See ada_lookup_symbol_list_worker for further details. */
5810
5811int
b5ec771e 5812ada_lookup_symbol_list (const char *name, const struct block *block,
54d343a2
TT
5813 domain_enum domain,
5814 std::vector<struct block_symbol> *results)
4eeaa230 5815{
b5ec771e
PA
5816 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5817 lookup_name_info lookup_name (name, name_match_type);
5818
5819 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5820}
5821
5822/* Implementation of the la_iterate_over_symbols method. */
5823
5824static void
14bc53a8 5825ada_iterate_over_symbols
b5ec771e
PA
5826 (const struct block *block, const lookup_name_info &name,
5827 domain_enum domain,
14bc53a8 5828 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5829{
5830 int ndefs, i;
54d343a2 5831 std::vector<struct block_symbol> results;
4eeaa230
DE
5832
5833 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2 5834
4eeaa230
DE
5835 for (i = 0; i < ndefs; ++i)
5836 {
7e41c8db 5837 if (!callback (&results[i]))
4eeaa230
DE
5838 break;
5839 }
5840}
5841
4e5c77fe
JB
5842/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5843 to 1, but choosing the first symbol found if there are multiple
5844 choices.
5845
5e2336be
JB
5846 The result is stored in *INFO, which must be non-NULL.
5847 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5848
5849void
5850ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5851 domain_enum domain,
d12307c1 5852 struct block_symbol *info)
14f9c5c9 5853{
b5ec771e
PA
5854 /* Since we already have an encoded name, wrap it in '<>' to force a
5855 verbatim match. Otherwise, if the name happens to not look like
5856 an encoded name (because it doesn't include a "__"),
5857 ada_lookup_name_info would re-encode/fold it again, and that
5858 would e.g., incorrectly lowercase object renaming names like
5859 "R28b" -> "r28b". */
5860 std::string verbatim = std::string ("<") + name + '>';
5861
5e2336be 5862 gdb_assert (info != NULL);
f98fc17b 5863 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5864}
aeb5907d
JB
5865
5866/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5867 scope and in global scopes, or NULL if none. NAME is folded and
5868 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5869 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5870 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5871
d12307c1 5872struct block_symbol
aeb5907d 5873ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5874 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5875{
5876 if (is_a_field_of_this != NULL)
5877 *is_a_field_of_this = 0;
5878
54d343a2 5879 std::vector<struct block_symbol> candidates;
f98fc17b 5880 int n_candidates;
f98fc17b
PA
5881
5882 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
f98fc17b
PA
5883
5884 if (n_candidates == 0)
54d343a2 5885 return {};
f98fc17b
PA
5886
5887 block_symbol info = candidates[0];
5888 info.symbol = fixup_symbol_section (info.symbol, NULL);
d12307c1 5889 return info;
4c4b4cd2 5890}
14f9c5c9 5891
d12307c1 5892static struct block_symbol
f606139a
DE
5893ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5894 const char *name,
76a01679 5895 const struct block *block,
21b556f4 5896 const domain_enum domain)
4c4b4cd2 5897{
d12307c1 5898 struct block_symbol sym;
04dccad0
JB
5899
5900 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5901 if (sym.symbol != NULL)
04dccad0
JB
5902 return sym;
5903
5904 /* If we haven't found a match at this point, try the primitive
5905 types. In other languages, this search is performed before
5906 searching for global symbols in order to short-circuit that
5907 global-symbol search if it happens that the name corresponds
5908 to a primitive type. But we cannot do the same in Ada, because
5909 it is perfectly legitimate for a program to declare a type which
5910 has the same name as a standard type. If looking up a type in
5911 that situation, we have traditionally ignored the primitive type
5912 in favor of user-defined types. This is why, unlike most other
5913 languages, we search the primitive types this late and only after
5914 having searched the global symbols without success. */
5915
5916 if (domain == VAR_DOMAIN)
5917 {
5918 struct gdbarch *gdbarch;
5919
5920 if (block == NULL)
5921 gdbarch = target_gdbarch ();
5922 else
5923 gdbarch = block_gdbarch (block);
d12307c1
PMR
5924 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5925 if (sym.symbol != NULL)
04dccad0
JB
5926 return sym;
5927 }
5928
6640a367 5929 return {};
14f9c5c9
AS
5930}
5931
5932
4c4b4cd2
PH
5933/* True iff STR is a possible encoded suffix of a normal Ada name
5934 that is to be ignored for matching purposes. Suffixes of parallel
5935 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5936 are given by any of the regular expressions:
4c4b4cd2 5937
babe1480
JB
5938 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5939 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5940 TKB [subprogram suffix for task bodies]
babe1480 5941 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5942 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5943
5944 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5945 match is performed. This sequence is used to differentiate homonyms,
5946 is an optional part of a valid name suffix. */
4c4b4cd2 5947
14f9c5c9 5948static int
d2e4a39e 5949is_name_suffix (const char *str)
14f9c5c9
AS
5950{
5951 int k;
4c4b4cd2
PH
5952 const char *matching;
5953 const int len = strlen (str);
5954
babe1480
JB
5955 /* Skip optional leading __[0-9]+. */
5956
4c4b4cd2
PH
5957 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5958 {
babe1480
JB
5959 str += 3;
5960 while (isdigit (str[0]))
5961 str += 1;
4c4b4cd2 5962 }
babe1480
JB
5963
5964 /* [.$][0-9]+ */
4c4b4cd2 5965
babe1480 5966 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5967 {
babe1480 5968 matching = str + 1;
4c4b4cd2
PH
5969 while (isdigit (matching[0]))
5970 matching += 1;
5971 if (matching[0] == '\0')
5972 return 1;
5973 }
5974
5975 /* ___[0-9]+ */
babe1480 5976
4c4b4cd2
PH
5977 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5978 {
5979 matching = str + 3;
5980 while (isdigit (matching[0]))
5981 matching += 1;
5982 if (matching[0] == '\0')
5983 return 1;
5984 }
5985
9ac7f98e
JB
5986 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5987
5988 if (strcmp (str, "TKB") == 0)
5989 return 1;
5990
529cad9c
PH
5991#if 0
5992 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5993 with a N at the end. Unfortunately, the compiler uses the same
5994 convention for other internal types it creates. So treating
529cad9c 5995 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5996 some regressions. For instance, consider the case of an enumerated
5997 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5998 name ends with N.
5999 Having a single character like this as a suffix carrying some
0963b4bd 6000 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
6001 to be something like "_N" instead. In the meantime, do not do
6002 the following check. */
6003 /* Protected Object Subprograms */
6004 if (len == 1 && str [0] == 'N')
6005 return 1;
6006#endif
6007
6008 /* _E[0-9]+[bs]$ */
6009 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6010 {
6011 matching = str + 3;
6012 while (isdigit (matching[0]))
6013 matching += 1;
6014 if ((matching[0] == 'b' || matching[0] == 's')
6015 && matching [1] == '\0')
6016 return 1;
6017 }
6018
4c4b4cd2
PH
6019 /* ??? We should not modify STR directly, as we are doing below. This
6020 is fine in this case, but may become problematic later if we find
6021 that this alternative did not work, and want to try matching
6022 another one from the begining of STR. Since we modified it, we
6023 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6024 if (str[0] == 'X')
6025 {
6026 str += 1;
d2e4a39e 6027 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6028 {
6029 if (str[0] != 'n' && str[0] != 'b')
6030 return 0;
6031 str += 1;
6032 }
14f9c5c9 6033 }
babe1480 6034
14f9c5c9
AS
6035 if (str[0] == '\000')
6036 return 1;
babe1480 6037
d2e4a39e 6038 if (str[0] == '_')
14f9c5c9
AS
6039 {
6040 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6041 return 0;
d2e4a39e 6042 if (str[2] == '_')
4c4b4cd2 6043 {
61ee279c
PH
6044 if (strcmp (str + 3, "JM") == 0)
6045 return 1;
6046 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6047 the LJM suffix in favor of the JM one. But we will
6048 still accept LJM as a valid suffix for a reasonable
6049 amount of time, just to allow ourselves to debug programs
6050 compiled using an older version of GNAT. */
4c4b4cd2
PH
6051 if (strcmp (str + 3, "LJM") == 0)
6052 return 1;
6053 if (str[3] != 'X')
6054 return 0;
1265e4aa
JB
6055 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6056 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6057 return 1;
6058 if (str[4] == 'R' && str[5] != 'T')
6059 return 1;
6060 return 0;
6061 }
6062 if (!isdigit (str[2]))
6063 return 0;
6064 for (k = 3; str[k] != '\0'; k += 1)
6065 if (!isdigit (str[k]) && str[k] != '_')
6066 return 0;
14f9c5c9
AS
6067 return 1;
6068 }
4c4b4cd2 6069 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6070 {
4c4b4cd2
PH
6071 for (k = 2; str[k] != '\0'; k += 1)
6072 if (!isdigit (str[k]) && str[k] != '_')
6073 return 0;
14f9c5c9
AS
6074 return 1;
6075 }
6076 return 0;
6077}
d2e4a39e 6078
aeb5907d
JB
6079/* Return non-zero if the string starting at NAME and ending before
6080 NAME_END contains no capital letters. */
529cad9c
PH
6081
6082static int
6083is_valid_name_for_wild_match (const char *name0)
6084{
6085 const char *decoded_name = ada_decode (name0);
6086 int i;
6087
5823c3ef
JB
6088 /* If the decoded name starts with an angle bracket, it means that
6089 NAME0 does not follow the GNAT encoding format. It should then
6090 not be allowed as a possible wild match. */
6091 if (decoded_name[0] == '<')
6092 return 0;
6093
529cad9c
PH
6094 for (i=0; decoded_name[i] != '\0'; i++)
6095 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6096 return 0;
6097
6098 return 1;
6099}
6100
73589123
PH
6101/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6102 that could start a simple name. Assumes that *NAMEP points into
6103 the string beginning at NAME0. */
4c4b4cd2 6104
14f9c5c9 6105static int
73589123 6106advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6107{
73589123 6108 const char *name = *namep;
5b4ee69b 6109
5823c3ef 6110 while (1)
14f9c5c9 6111 {
aa27d0b3 6112 int t0, t1;
73589123
PH
6113
6114 t0 = *name;
6115 if (t0 == '_')
6116 {
6117 t1 = name[1];
6118 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6119 {
6120 name += 1;
61012eef 6121 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6122 break;
6123 else
6124 name += 1;
6125 }
aa27d0b3
JB
6126 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6127 || name[2] == target0))
73589123
PH
6128 {
6129 name += 2;
6130 break;
6131 }
6132 else
6133 return 0;
6134 }
6135 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6136 name += 1;
6137 else
5823c3ef 6138 return 0;
73589123
PH
6139 }
6140
6141 *namep = name;
6142 return 1;
6143}
6144
b5ec771e
PA
6145/* Return true iff NAME encodes a name of the form prefix.PATN.
6146 Ignores any informational suffixes of NAME (i.e., for which
6147 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6148 simple name. */
73589123 6149
b5ec771e 6150static bool
73589123
PH
6151wild_match (const char *name, const char *patn)
6152{
22e048c9 6153 const char *p;
73589123
PH
6154 const char *name0 = name;
6155
6156 while (1)
6157 {
6158 const char *match = name;
6159
6160 if (*name == *patn)
6161 {
6162 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6163 if (*p != *name)
6164 break;
6165 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6166 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6167
6168 if (name[-1] == '_')
6169 name -= 1;
6170 }
6171 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6172 return false;
96d887e8 6173 }
96d887e8
PH
6174}
6175
b5ec771e
PA
6176/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6177 any trailing suffixes that encode debugging information or leading
6178 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6179 information that is ignored). */
40658b94 6180
b5ec771e 6181static bool
c4d840bd
PH
6182full_match (const char *sym_name, const char *search_name)
6183{
b5ec771e
PA
6184 size_t search_name_len = strlen (search_name);
6185
6186 if (strncmp (sym_name, search_name, search_name_len) == 0
6187 && is_name_suffix (sym_name + search_name_len))
6188 return true;
6189
6190 if (startswith (sym_name, "_ada_")
6191 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6192 && is_name_suffix (sym_name + search_name_len + 5))
6193 return true;
c4d840bd 6194
b5ec771e
PA
6195 return false;
6196}
c4d840bd 6197
b5ec771e
PA
6198/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6199 *defn_symbols, updating the list of symbols in OBSTACKP (if
6200 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6201
6202static void
6203ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6204 const struct block *block,
6205 const lookup_name_info &lookup_name,
6206 domain_enum domain, struct objfile *objfile)
96d887e8 6207{
8157b174 6208 struct block_iterator iter;
96d887e8
PH
6209 /* A matching argument symbol, if any. */
6210 struct symbol *arg_sym;
6211 /* Set true when we find a matching non-argument symbol. */
6212 int found_sym;
6213 struct symbol *sym;
6214
6215 arg_sym = NULL;
6216 found_sym = 0;
b5ec771e
PA
6217 for (sym = block_iter_match_first (block, lookup_name, &iter);
6218 sym != NULL;
6219 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6220 {
b5ec771e
PA
6221 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6222 SYMBOL_DOMAIN (sym), domain))
6223 {
6224 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6225 {
6226 if (SYMBOL_IS_ARGUMENT (sym))
6227 arg_sym = sym;
6228 else
6229 {
6230 found_sym = 1;
6231 add_defn_to_vec (obstackp,
6232 fixup_symbol_section (sym, objfile),
6233 block);
6234 }
6235 }
6236 }
96d887e8
PH
6237 }
6238
22cee43f
PMR
6239 /* Handle renamings. */
6240
b5ec771e 6241 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6242 found_sym = 1;
6243
96d887e8
PH
6244 if (!found_sym && arg_sym != NULL)
6245 {
76a01679
JB
6246 add_defn_to_vec (obstackp,
6247 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6248 block);
96d887e8
PH
6249 }
6250
b5ec771e 6251 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6252 {
6253 arg_sym = NULL;
6254 found_sym = 0;
b5ec771e
PA
6255 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6256 const char *name = ada_lookup_name.c_str ();
6257 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6258
6259 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6260 {
4186eb54
KS
6261 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6262 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6263 {
6264 int cmp;
6265
6266 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6267 if (cmp == 0)
6268 {
61012eef 6269 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6270 if (cmp == 0)
6271 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6272 name_len);
6273 }
6274
6275 if (cmp == 0
6276 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6277 {
2a2d4dc3
AS
6278 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6279 {
6280 if (SYMBOL_IS_ARGUMENT (sym))
6281 arg_sym = sym;
6282 else
6283 {
6284 found_sym = 1;
6285 add_defn_to_vec (obstackp,
6286 fixup_symbol_section (sym, objfile),
6287 block);
6288 }
6289 }
76a01679
JB
6290 }
6291 }
76a01679 6292 }
96d887e8
PH
6293
6294 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6295 They aren't parameters, right? */
6296 if (!found_sym && arg_sym != NULL)
6297 {
6298 add_defn_to_vec (obstackp,
76a01679 6299 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6300 block);
96d887e8
PH
6301 }
6302 }
6303}
6304\f
41d27058
JB
6305
6306 /* Symbol Completion */
6307
b5ec771e 6308/* See symtab.h. */
41d27058 6309
b5ec771e
PA
6310bool
6311ada_lookup_name_info::matches
6312 (const char *sym_name,
6313 symbol_name_match_type match_type,
a207cff2 6314 completion_match_result *comp_match_res) const
41d27058 6315{
b5ec771e
PA
6316 bool match = false;
6317 const char *text = m_encoded_name.c_str ();
6318 size_t text_len = m_encoded_name.size ();
41d27058
JB
6319
6320 /* First, test against the fully qualified name of the symbol. */
6321
6322 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6323 match = true;
41d27058 6324
b5ec771e 6325 if (match && !m_encoded_p)
41d27058
JB
6326 {
6327 /* One needed check before declaring a positive match is to verify
6328 that iff we are doing a verbatim match, the decoded version
6329 of the symbol name starts with '<'. Otherwise, this symbol name
6330 is not a suitable completion. */
6331 const char *sym_name_copy = sym_name;
b5ec771e 6332 bool has_angle_bracket;
41d27058
JB
6333
6334 sym_name = ada_decode (sym_name);
6335 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6336 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6337 sym_name = sym_name_copy;
6338 }
6339
b5ec771e 6340 if (match && !m_verbatim_p)
41d27058
JB
6341 {
6342 /* When doing non-verbatim match, another check that needs to
6343 be done is to verify that the potentially matching symbol name
6344 does not include capital letters, because the ada-mode would
6345 not be able to understand these symbol names without the
6346 angle bracket notation. */
6347 const char *tmp;
6348
6349 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6350 if (*tmp != '\0')
b5ec771e 6351 match = false;
41d27058
JB
6352 }
6353
6354 /* Second: Try wild matching... */
6355
b5ec771e 6356 if (!match && m_wild_match_p)
41d27058
JB
6357 {
6358 /* Since we are doing wild matching, this means that TEXT
6359 may represent an unqualified symbol name. We therefore must
6360 also compare TEXT against the unqualified name of the symbol. */
6361 sym_name = ada_unqualified_name (ada_decode (sym_name));
6362
6363 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6364 match = true;
41d27058
JB
6365 }
6366
b5ec771e 6367 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6368
6369 if (!match)
b5ec771e 6370 return false;
41d27058 6371
a207cff2 6372 if (comp_match_res != NULL)
b5ec771e 6373 {
a207cff2 6374 std::string &match_str = comp_match_res->match.storage ();
41d27058 6375
b5ec771e 6376 if (!m_encoded_p)
a207cff2 6377 match_str = ada_decode (sym_name);
b5ec771e
PA
6378 else
6379 {
6380 if (m_verbatim_p)
6381 match_str = add_angle_brackets (sym_name);
6382 else
6383 match_str = sym_name;
41d27058 6384
b5ec771e 6385 }
a207cff2
PA
6386
6387 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6388 }
6389
b5ec771e 6390 return true;
41d27058
JB
6391}
6392
b5ec771e 6393/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6394 WORD is the entire command on which completion is made. */
41d27058 6395
eb3ff9a5
PA
6396static void
6397ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6398 complete_symbol_mode mode,
b5ec771e
PA
6399 symbol_name_match_type name_match_type,
6400 const char *text, const char *word,
eb3ff9a5 6401 enum type_code code)
41d27058 6402{
41d27058 6403 struct symbol *sym;
3977b71f 6404 const struct block *b, *surrounding_static_block = 0;
8157b174 6405 struct block_iterator iter;
41d27058 6406
2f68a895
TT
6407 gdb_assert (code == TYPE_CODE_UNDEF);
6408
1b026119 6409 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6410
6411 /* First, look at the partial symtab symbols. */
14bc53a8 6412 expand_symtabs_matching (NULL,
b5ec771e
PA
6413 lookup_name,
6414 NULL,
14bc53a8
PA
6415 NULL,
6416 ALL_DOMAIN);
41d27058
JB
6417
6418 /* At this point scan through the misc symbol vectors and add each
6419 symbol you find to the list. Eventually we want to ignore
6420 anything that isn't a text symbol (everything else will be
6421 handled by the psymtab code above). */
6422
2030c079 6423 for (objfile *objfile : current_program_space->objfiles ())
5325b9bf 6424 {
7932255d 6425 for (minimal_symbol *msymbol : objfile->msymbols ())
5325b9bf
TT
6426 {
6427 QUIT;
6428
6429 if (completion_skip_symbol (mode, msymbol))
6430 continue;
6431
6432 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6433
6434 /* Ada minimal symbols won't have their language set to Ada. If
6435 we let completion_list_add_name compare using the
6436 default/C-like matcher, then when completing e.g., symbols in a
6437 package named "pck", we'd match internal Ada symbols like
6438 "pckS", which are invalid in an Ada expression, unless you wrap
6439 them in '<' '>' to request a verbatim match.
6440
6441 Unfortunately, some Ada encoded names successfully demangle as
6442 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6443 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6444 with the wrong language set. Paper over that issue here. */
6445 if (symbol_language == language_auto
6446 || symbol_language == language_cplus)
6447 symbol_language = language_ada;
6448
6449 completion_list_add_name (tracker,
6450 symbol_language,
6451 MSYMBOL_LINKAGE_NAME (msymbol),
6452 lookup_name, text, word);
6453 }
6454 }
41d27058
JB
6455
6456 /* Search upwards from currently selected frame (so that we can
6457 complete on local vars. */
6458
6459 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6460 {
6461 if (!BLOCK_SUPERBLOCK (b))
6462 surrounding_static_block = b; /* For elmin of dups */
6463
6464 ALL_BLOCK_SYMBOLS (b, iter, sym)
6465 {
f9d67a22
PA
6466 if (completion_skip_symbol (mode, sym))
6467 continue;
6468
b5ec771e
PA
6469 completion_list_add_name (tracker,
6470 SYMBOL_LANGUAGE (sym),
6471 SYMBOL_LINKAGE_NAME (sym),
1b026119 6472 lookup_name, text, word);
41d27058
JB
6473 }
6474 }
6475
6476 /* Go through the symtabs and check the externs and statics for
43f3e411 6477 symbols which match. */
41d27058 6478
2030c079 6479 for (objfile *objfile : current_program_space->objfiles ())
41d27058 6480 {
b669c953 6481 for (compunit_symtab *s : objfile->compunits ())
d8aeb77f
TT
6482 {
6483 QUIT;
6484 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6485 ALL_BLOCK_SYMBOLS (b, iter, sym)
6486 {
6487 if (completion_skip_symbol (mode, sym))
6488 continue;
f9d67a22 6489
d8aeb77f
TT
6490 completion_list_add_name (tracker,
6491 SYMBOL_LANGUAGE (sym),
6492 SYMBOL_LINKAGE_NAME (sym),
6493 lookup_name, text, word);
6494 }
6495 }
41d27058 6496 }
41d27058 6497
2030c079 6498 for (objfile *objfile : current_program_space->objfiles ())
d8aeb77f 6499 {
b669c953 6500 for (compunit_symtab *s : objfile->compunits ())
d8aeb77f
TT
6501 {
6502 QUIT;
6503 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6504 /* Don't do this block twice. */
6505 if (b == surrounding_static_block)
6506 continue;
6507 ALL_BLOCK_SYMBOLS (b, iter, sym)
6508 {
6509 if (completion_skip_symbol (mode, sym))
6510 continue;
f9d67a22 6511
d8aeb77f
TT
6512 completion_list_add_name (tracker,
6513 SYMBOL_LANGUAGE (sym),
6514 SYMBOL_LINKAGE_NAME (sym),
6515 lookup_name, text, word);
6516 }
6517 }
41d27058 6518 }
41d27058
JB
6519}
6520
963a6417 6521 /* Field Access */
96d887e8 6522
73fb9985
JB
6523/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6524 for tagged types. */
6525
6526static int
6527ada_is_dispatch_table_ptr_type (struct type *type)
6528{
0d5cff50 6529 const char *name;
73fb9985
JB
6530
6531 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6532 return 0;
6533
6534 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6535 if (name == NULL)
6536 return 0;
6537
6538 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6539}
6540
ac4a2da4
JG
6541/* Return non-zero if TYPE is an interface tag. */
6542
6543static int
6544ada_is_interface_tag (struct type *type)
6545{
6546 const char *name = TYPE_NAME (type);
6547
6548 if (name == NULL)
6549 return 0;
6550
6551 return (strcmp (name, "ada__tags__interface_tag") == 0);
6552}
6553
963a6417
PH
6554/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6555 to be invisible to users. */
96d887e8 6556
963a6417
PH
6557int
6558ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6559{
963a6417
PH
6560 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6561 return 1;
ffde82bf 6562
73fb9985
JB
6563 /* Check the name of that field. */
6564 {
6565 const char *name = TYPE_FIELD_NAME (type, field_num);
6566
6567 /* Anonymous field names should not be printed.
6568 brobecker/2007-02-20: I don't think this can actually happen
6569 but we don't want to print the value of annonymous fields anyway. */
6570 if (name == NULL)
6571 return 1;
6572
ffde82bf
JB
6573 /* Normally, fields whose name start with an underscore ("_")
6574 are fields that have been internally generated by the compiler,
6575 and thus should not be printed. The "_parent" field is special,
6576 however: This is a field internally generated by the compiler
6577 for tagged types, and it contains the components inherited from
6578 the parent type. This field should not be printed as is, but
6579 should not be ignored either. */
61012eef 6580 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6581 return 1;
6582 }
6583
ac4a2da4
JG
6584 /* If this is the dispatch table of a tagged type or an interface tag,
6585 then ignore. */
73fb9985 6586 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6587 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6588 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6589 return 1;
6590
6591 /* Not a special field, so it should not be ignored. */
6592 return 0;
963a6417 6593}
96d887e8 6594
963a6417 6595/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6596 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6597
963a6417
PH
6598int
6599ada_is_tagged_type (struct type *type, int refok)
6600{
988f6b3d 6601 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6602}
96d887e8 6603
963a6417 6604/* True iff TYPE represents the type of X'Tag */
96d887e8 6605
963a6417
PH
6606int
6607ada_is_tag_type (struct type *type)
6608{
460efde1
JB
6609 type = ada_check_typedef (type);
6610
963a6417
PH
6611 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6612 return 0;
6613 else
96d887e8 6614 {
963a6417 6615 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6616
963a6417
PH
6617 return (name != NULL
6618 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6619 }
96d887e8
PH
6620}
6621
963a6417 6622/* The type of the tag on VAL. */
76a01679 6623
963a6417
PH
6624struct type *
6625ada_tag_type (struct value *val)
96d887e8 6626{
988f6b3d 6627 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6628}
96d887e8 6629
b50d69b5
JG
6630/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6631 retired at Ada 05). */
6632
6633static int
6634is_ada95_tag (struct value *tag)
6635{
6636 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6637}
6638
963a6417 6639/* The value of the tag on VAL. */
96d887e8 6640
963a6417
PH
6641struct value *
6642ada_value_tag (struct value *val)
6643{
03ee6b2e 6644 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6645}
6646
963a6417
PH
6647/* The value of the tag on the object of type TYPE whose contents are
6648 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6649 ADDRESS. */
96d887e8 6650
963a6417 6651static struct value *
10a2c479 6652value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6653 const gdb_byte *valaddr,
963a6417 6654 CORE_ADDR address)
96d887e8 6655{
b5385fc0 6656 int tag_byte_offset;
963a6417 6657 struct type *tag_type;
5b4ee69b 6658
963a6417 6659 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6660 NULL, NULL, NULL))
96d887e8 6661 {
fc1a4b47 6662 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6663 ? NULL
6664 : valaddr + tag_byte_offset);
963a6417 6665 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6666
963a6417 6667 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6668 }
963a6417
PH
6669 return NULL;
6670}
96d887e8 6671
963a6417
PH
6672static struct type *
6673type_from_tag (struct value *tag)
6674{
6675 const char *type_name = ada_tag_name (tag);
5b4ee69b 6676
963a6417
PH
6677 if (type_name != NULL)
6678 return ada_find_any_type (ada_encode (type_name));
6679 return NULL;
6680}
96d887e8 6681
b50d69b5
JG
6682/* Given a value OBJ of a tagged type, return a value of this
6683 type at the base address of the object. The base address, as
6684 defined in Ada.Tags, it is the address of the primary tag of
6685 the object, and therefore where the field values of its full
6686 view can be fetched. */
6687
6688struct value *
6689ada_tag_value_at_base_address (struct value *obj)
6690{
b50d69b5
JG
6691 struct value *val;
6692 LONGEST offset_to_top = 0;
6693 struct type *ptr_type, *obj_type;
6694 struct value *tag;
6695 CORE_ADDR base_address;
6696
6697 obj_type = value_type (obj);
6698
6699 /* It is the responsability of the caller to deref pointers. */
6700
6701 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6702 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6703 return obj;
6704
6705 tag = ada_value_tag (obj);
6706 if (!tag)
6707 return obj;
6708
6709 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6710
6711 if (is_ada95_tag (tag))
6712 return obj;
6713
08f49010
XR
6714 ptr_type = language_lookup_primitive_type
6715 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6716 ptr_type = lookup_pointer_type (ptr_type);
6717 val = value_cast (ptr_type, tag);
6718 if (!val)
6719 return obj;
6720
6721 /* It is perfectly possible that an exception be raised while
6722 trying to determine the base address, just like for the tag;
6723 see ada_tag_name for more details. We do not print the error
6724 message for the same reason. */
6725
492d29ea 6726 TRY
b50d69b5
JG
6727 {
6728 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6729 }
6730
492d29ea
PA
6731 CATCH (e, RETURN_MASK_ERROR)
6732 {
6733 return obj;
6734 }
6735 END_CATCH
b50d69b5
JG
6736
6737 /* If offset is null, nothing to do. */
6738
6739 if (offset_to_top == 0)
6740 return obj;
6741
6742 /* -1 is a special case in Ada.Tags; however, what should be done
6743 is not quite clear from the documentation. So do nothing for
6744 now. */
6745
6746 if (offset_to_top == -1)
6747 return obj;
6748
08f49010
XR
6749 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6750 from the base address. This was however incompatible with
6751 C++ dispatch table: C++ uses a *negative* value to *add*
6752 to the base address. Ada's convention has therefore been
6753 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6754 use the same convention. Here, we support both cases by
6755 checking the sign of OFFSET_TO_TOP. */
6756
6757 if (offset_to_top > 0)
6758 offset_to_top = -offset_to_top;
6759
6760 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6761 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6762
6763 /* Make sure that we have a proper tag at the new address.
6764 Otherwise, offset_to_top is bogus (which can happen when
6765 the object is not initialized yet). */
6766
6767 if (!tag)
6768 return obj;
6769
6770 obj_type = type_from_tag (tag);
6771
6772 if (!obj_type)
6773 return obj;
6774
6775 return value_from_contents_and_address (obj_type, NULL, base_address);
6776}
6777
1b611343
JB
6778/* Return the "ada__tags__type_specific_data" type. */
6779
6780static struct type *
6781ada_get_tsd_type (struct inferior *inf)
963a6417 6782{
1b611343 6783 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6784
1b611343
JB
6785 if (data->tsd_type == 0)
6786 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6787 return data->tsd_type;
6788}
529cad9c 6789
1b611343
JB
6790/* Return the TSD (type-specific data) associated to the given TAG.
6791 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6792
1b611343 6793 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6794
1b611343
JB
6795static struct value *
6796ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6797{
4c4b4cd2 6798 struct value *val;
1b611343 6799 struct type *type;
5b4ee69b 6800
1b611343
JB
6801 /* First option: The TSD is simply stored as a field of our TAG.
6802 Only older versions of GNAT would use this format, but we have
6803 to test it first, because there are no visible markers for
6804 the current approach except the absence of that field. */
529cad9c 6805
1b611343
JB
6806 val = ada_value_struct_elt (tag, "tsd", 1);
6807 if (val)
6808 return val;
e802dbe0 6809
1b611343
JB
6810 /* Try the second representation for the dispatch table (in which
6811 there is no explicit 'tsd' field in the referent of the tag pointer,
6812 and instead the tsd pointer is stored just before the dispatch
6813 table. */
e802dbe0 6814
1b611343
JB
6815 type = ada_get_tsd_type (current_inferior());
6816 if (type == NULL)
6817 return NULL;
6818 type = lookup_pointer_type (lookup_pointer_type (type));
6819 val = value_cast (type, tag);
6820 if (val == NULL)
6821 return NULL;
6822 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6823}
6824
1b611343
JB
6825/* Given the TSD of a tag (type-specific data), return a string
6826 containing the name of the associated type.
6827
6828 The returned value is good until the next call. May return NULL
6829 if we are unable to determine the tag name. */
6830
6831static char *
6832ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6833{
529cad9c
PH
6834 static char name[1024];
6835 char *p;
1b611343 6836 struct value *val;
529cad9c 6837
1b611343 6838 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6839 if (val == NULL)
1b611343 6840 return NULL;
4c4b4cd2
PH
6841 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6842 for (p = name; *p != '\0'; p += 1)
6843 if (isalpha (*p))
6844 *p = tolower (*p);
1b611343 6845 return name;
4c4b4cd2
PH
6846}
6847
6848/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6849 a C string.
6850
6851 Return NULL if the TAG is not an Ada tag, or if we were unable to
6852 determine the name of that tag. The result is good until the next
6853 call. */
4c4b4cd2
PH
6854
6855const char *
6856ada_tag_name (struct value *tag)
6857{
1b611343 6858 char *name = NULL;
5b4ee69b 6859
df407dfe 6860 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6861 return NULL;
1b611343
JB
6862
6863 /* It is perfectly possible that an exception be raised while trying
6864 to determine the TAG's name, even under normal circumstances:
6865 The associated variable may be uninitialized or corrupted, for
6866 instance. We do not let any exception propagate past this point.
6867 instead we return NULL.
6868
6869 We also do not print the error message either (which often is very
6870 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6871 the caller print a more meaningful message if necessary. */
492d29ea 6872 TRY
1b611343
JB
6873 {
6874 struct value *tsd = ada_get_tsd_from_tag (tag);
6875
6876 if (tsd != NULL)
6877 name = ada_tag_name_from_tsd (tsd);
6878 }
492d29ea
PA
6879 CATCH (e, RETURN_MASK_ERROR)
6880 {
6881 }
6882 END_CATCH
1b611343
JB
6883
6884 return name;
4c4b4cd2
PH
6885}
6886
6887/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6888
d2e4a39e 6889struct type *
ebf56fd3 6890ada_parent_type (struct type *type)
14f9c5c9
AS
6891{
6892 int i;
6893
61ee279c 6894 type = ada_check_typedef (type);
14f9c5c9
AS
6895
6896 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6897 return NULL;
6898
6899 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6900 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6901 {
6902 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6903
6904 /* If the _parent field is a pointer, then dereference it. */
6905 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6906 parent_type = TYPE_TARGET_TYPE (parent_type);
6907 /* If there is a parallel XVS type, get the actual base type. */
6908 parent_type = ada_get_base_type (parent_type);
6909
6910 return ada_check_typedef (parent_type);
6911 }
14f9c5c9
AS
6912
6913 return NULL;
6914}
6915
4c4b4cd2
PH
6916/* True iff field number FIELD_NUM of structure type TYPE contains the
6917 parent-type (inherited) fields of a derived type. Assumes TYPE is
6918 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6919
6920int
ebf56fd3 6921ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6922{
61ee279c 6923 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6924
4c4b4cd2 6925 return (name != NULL
61012eef
GB
6926 && (startswith (name, "PARENT")
6927 || startswith (name, "_parent")));
14f9c5c9
AS
6928}
6929
4c4b4cd2 6930/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6931 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6932 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6933 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6934 structures. */
14f9c5c9
AS
6935
6936int
ebf56fd3 6937ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6938{
d2e4a39e 6939 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6940
dddc0e16
JB
6941 if (name != NULL && strcmp (name, "RETVAL") == 0)
6942 {
6943 /* This happens in functions with "out" or "in out" parameters
6944 which are passed by copy. For such functions, GNAT describes
6945 the function's return type as being a struct where the return
6946 value is in a field called RETVAL, and where the other "out"
6947 or "in out" parameters are fields of that struct. This is not
6948 a wrapper. */
6949 return 0;
6950 }
6951
d2e4a39e 6952 return (name != NULL
61012eef 6953 && (startswith (name, "PARENT")
4c4b4cd2 6954 || strcmp (name, "REP") == 0
61012eef 6955 || startswith (name, "_parent")
4c4b4cd2 6956 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6957}
6958
4c4b4cd2
PH
6959/* True iff field number FIELD_NUM of structure or union type TYPE
6960 is a variant wrapper. Assumes TYPE is a structure type with at least
6961 FIELD_NUM+1 fields. */
14f9c5c9
AS
6962
6963int
ebf56fd3 6964ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6965{
d2e4a39e 6966 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6967
14f9c5c9 6968 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6969 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6970 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6971 == TYPE_CODE_UNION)));
14f9c5c9
AS
6972}
6973
6974/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6975 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6976 returns the type of the controlling discriminant for the variant.
6977 May return NULL if the type could not be found. */
14f9c5c9 6978
d2e4a39e 6979struct type *
ebf56fd3 6980ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6981{
a121b7c1 6982 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6983
988f6b3d 6984 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
6985}
6986
4c4b4cd2 6987/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6988 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6989 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6990
6991int
ebf56fd3 6992ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6993{
d2e4a39e 6994 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6995
14f9c5c9
AS
6996 return (name != NULL && name[0] == 'O');
6997}
6998
6999/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
7000 returns the name of the discriminant controlling the variant.
7001 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 7002
a121b7c1 7003const char *
ebf56fd3 7004ada_variant_discrim_name (struct type *type0)
14f9c5c9 7005{
d2e4a39e 7006 static char *result = NULL;
14f9c5c9 7007 static size_t result_len = 0;
d2e4a39e
AS
7008 struct type *type;
7009 const char *name;
7010 const char *discrim_end;
7011 const char *discrim_start;
14f9c5c9
AS
7012
7013 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7014 type = TYPE_TARGET_TYPE (type0);
7015 else
7016 type = type0;
7017
7018 name = ada_type_name (type);
7019
7020 if (name == NULL || name[0] == '\000')
7021 return "";
7022
7023 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7024 discrim_end -= 1)
7025 {
61012eef 7026 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7027 break;
14f9c5c9
AS
7028 }
7029 if (discrim_end == name)
7030 return "";
7031
d2e4a39e 7032 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7033 discrim_start -= 1)
7034 {
d2e4a39e 7035 if (discrim_start == name + 1)
4c4b4cd2 7036 return "";
76a01679 7037 if ((discrim_start > name + 3
61012eef 7038 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7039 || discrim_start[-1] == '.')
7040 break;
14f9c5c9
AS
7041 }
7042
7043 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7044 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7045 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7046 return result;
7047}
7048
4c4b4cd2
PH
7049/* Scan STR for a subtype-encoded number, beginning at position K.
7050 Put the position of the character just past the number scanned in
7051 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7052 Return 1 if there was a valid number at the given position, and 0
7053 otherwise. A "subtype-encoded" number consists of the absolute value
7054 in decimal, followed by the letter 'm' to indicate a negative number.
7055 Assumes 0m does not occur. */
14f9c5c9
AS
7056
7057int
d2e4a39e 7058ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7059{
7060 ULONGEST RU;
7061
d2e4a39e 7062 if (!isdigit (str[k]))
14f9c5c9
AS
7063 return 0;
7064
4c4b4cd2 7065 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7066 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7067 LONGEST. */
14f9c5c9
AS
7068 RU = 0;
7069 while (isdigit (str[k]))
7070 {
d2e4a39e 7071 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7072 k += 1;
7073 }
7074
d2e4a39e 7075 if (str[k] == 'm')
14f9c5c9
AS
7076 {
7077 if (R != NULL)
4c4b4cd2 7078 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7079 k += 1;
7080 }
7081 else if (R != NULL)
7082 *R = (LONGEST) RU;
7083
4c4b4cd2 7084 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7085 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7086 number representable as a LONGEST (although either would probably work
7087 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7088 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7089
7090 if (new_k != NULL)
7091 *new_k = k;
7092 return 1;
7093}
7094
4c4b4cd2
PH
7095/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7096 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7097 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7098
d2e4a39e 7099int
ebf56fd3 7100ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7101{
d2e4a39e 7102 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7103 int p;
7104
7105 p = 0;
7106 while (1)
7107 {
d2e4a39e 7108 switch (name[p])
4c4b4cd2
PH
7109 {
7110 case '\0':
7111 return 0;
7112 case 'S':
7113 {
7114 LONGEST W;
5b4ee69b 7115
4c4b4cd2
PH
7116 if (!ada_scan_number (name, p + 1, &W, &p))
7117 return 0;
7118 if (val == W)
7119 return 1;
7120 break;
7121 }
7122 case 'R':
7123 {
7124 LONGEST L, U;
5b4ee69b 7125
4c4b4cd2
PH
7126 if (!ada_scan_number (name, p + 1, &L, &p)
7127 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7128 return 0;
7129 if (val >= L && val <= U)
7130 return 1;
7131 break;
7132 }
7133 case 'O':
7134 return 1;
7135 default:
7136 return 0;
7137 }
7138 }
7139}
7140
0963b4bd 7141/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7142
7143/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7144 ARG_TYPE, extract and return the value of one of its (non-static)
7145 fields. FIELDNO says which field. Differs from value_primitive_field
7146 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7147
4c4b4cd2 7148static struct value *
d2e4a39e 7149ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7150 struct type *arg_type)
14f9c5c9 7151{
14f9c5c9
AS
7152 struct type *type;
7153
61ee279c 7154 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7155 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7156
4c4b4cd2 7157 /* Handle packed fields. */
14f9c5c9
AS
7158
7159 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7160 {
7161 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7162 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7163
0fd88904 7164 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7165 offset + bit_pos / 8,
7166 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7167 }
7168 else
7169 return value_primitive_field (arg1, offset, fieldno, arg_type);
7170}
7171
52ce6436
PH
7172/* Find field with name NAME in object of type TYPE. If found,
7173 set the following for each argument that is non-null:
7174 - *FIELD_TYPE_P to the field's type;
7175 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7176 an object of that type;
7177 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7178 - *BIT_SIZE_P to its size in bits if the field is packed, and
7179 0 otherwise;
7180 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7181 fields up to but not including the desired field, or by the total
7182 number of fields if not found. A NULL value of NAME never
7183 matches; the function just counts visible fields in this case.
7184
828d5846
XR
7185 Notice that we need to handle when a tagged record hierarchy
7186 has some components with the same name, like in this scenario:
7187
7188 type Top_T is tagged record
7189 N : Integer := 1;
7190 U : Integer := 974;
7191 A : Integer := 48;
7192 end record;
7193
7194 type Middle_T is new Top.Top_T with record
7195 N : Character := 'a';
7196 C : Integer := 3;
7197 end record;
7198
7199 type Bottom_T is new Middle.Middle_T with record
7200 N : Float := 4.0;
7201 C : Character := '5';
7202 X : Integer := 6;
7203 A : Character := 'J';
7204 end record;
7205
7206 Let's say we now have a variable declared and initialized as follow:
7207
7208 TC : Top_A := new Bottom_T;
7209
7210 And then we use this variable to call this function
7211
7212 procedure Assign (Obj: in out Top_T; TV : Integer);
7213
7214 as follow:
7215
7216 Assign (Top_T (B), 12);
7217
7218 Now, we're in the debugger, and we're inside that procedure
7219 then and we want to print the value of obj.c:
7220
7221 Usually, the tagged record or one of the parent type owns the
7222 component to print and there's no issue but in this particular
7223 case, what does it mean to ask for Obj.C? Since the actual
7224 type for object is type Bottom_T, it could mean two things: type
7225 component C from the Middle_T view, but also component C from
7226 Bottom_T. So in that "undefined" case, when the component is
7227 not found in the non-resolved type (which includes all the
7228 components of the parent type), then resolve it and see if we
7229 get better luck once expanded.
7230
7231 In the case of homonyms in the derived tagged type, we don't
7232 guaranty anything, and pick the one that's easiest for us
7233 to program.
7234
0963b4bd 7235 Returns 1 if found, 0 otherwise. */
52ce6436 7236
4c4b4cd2 7237static int
0d5cff50 7238find_struct_field (const char *name, struct type *type, int offset,
76a01679 7239 struct type **field_type_p,
52ce6436
PH
7240 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7241 int *index_p)
4c4b4cd2
PH
7242{
7243 int i;
828d5846 7244 int parent_offset = -1;
4c4b4cd2 7245
61ee279c 7246 type = ada_check_typedef (type);
76a01679 7247
52ce6436
PH
7248 if (field_type_p != NULL)
7249 *field_type_p = NULL;
7250 if (byte_offset_p != NULL)
d5d6fca5 7251 *byte_offset_p = 0;
52ce6436
PH
7252 if (bit_offset_p != NULL)
7253 *bit_offset_p = 0;
7254 if (bit_size_p != NULL)
7255 *bit_size_p = 0;
7256
7257 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7258 {
7259 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7260 int fld_offset = offset + bit_pos / 8;
0d5cff50 7261 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7262
4c4b4cd2
PH
7263 if (t_field_name == NULL)
7264 continue;
7265
828d5846
XR
7266 else if (ada_is_parent_field (type, i))
7267 {
7268 /* This is a field pointing us to the parent type of a tagged
7269 type. As hinted in this function's documentation, we give
7270 preference to fields in the current record first, so what
7271 we do here is just record the index of this field before
7272 we skip it. If it turns out we couldn't find our field
7273 in the current record, then we'll get back to it and search
7274 inside it whether the field might exist in the parent. */
7275
7276 parent_offset = i;
7277 continue;
7278 }
7279
52ce6436 7280 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7281 {
7282 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7283
52ce6436
PH
7284 if (field_type_p != NULL)
7285 *field_type_p = TYPE_FIELD_TYPE (type, i);
7286 if (byte_offset_p != NULL)
7287 *byte_offset_p = fld_offset;
7288 if (bit_offset_p != NULL)
7289 *bit_offset_p = bit_pos % 8;
7290 if (bit_size_p != NULL)
7291 *bit_size_p = bit_size;
76a01679
JB
7292 return 1;
7293 }
4c4b4cd2
PH
7294 else if (ada_is_wrapper_field (type, i))
7295 {
52ce6436
PH
7296 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7297 field_type_p, byte_offset_p, bit_offset_p,
7298 bit_size_p, index_p))
76a01679
JB
7299 return 1;
7300 }
4c4b4cd2
PH
7301 else if (ada_is_variant_part (type, i))
7302 {
52ce6436
PH
7303 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7304 fixed type?? */
4c4b4cd2 7305 int j;
52ce6436
PH
7306 struct type *field_type
7307 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7308
52ce6436 7309 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7310 {
76a01679
JB
7311 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7312 fld_offset
7313 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7314 field_type_p, byte_offset_p,
52ce6436 7315 bit_offset_p, bit_size_p, index_p))
76a01679 7316 return 1;
4c4b4cd2
PH
7317 }
7318 }
52ce6436
PH
7319 else if (index_p != NULL)
7320 *index_p += 1;
4c4b4cd2 7321 }
828d5846
XR
7322
7323 /* Field not found so far. If this is a tagged type which
7324 has a parent, try finding that field in the parent now. */
7325
7326 if (parent_offset != -1)
7327 {
7328 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7329 int fld_offset = offset + bit_pos / 8;
7330
7331 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7332 fld_offset, field_type_p, byte_offset_p,
7333 bit_offset_p, bit_size_p, index_p))
7334 return 1;
7335 }
7336
4c4b4cd2
PH
7337 return 0;
7338}
7339
0963b4bd 7340/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7341
52ce6436
PH
7342static int
7343num_visible_fields (struct type *type)
7344{
7345 int n;
5b4ee69b 7346
52ce6436
PH
7347 n = 0;
7348 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7349 return n;
7350}
14f9c5c9 7351
4c4b4cd2 7352/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7353 and search in it assuming it has (class) type TYPE.
7354 If found, return value, else return NULL.
7355
828d5846
XR
7356 Searches recursively through wrapper fields (e.g., '_parent').
7357
7358 In the case of homonyms in the tagged types, please refer to the
7359 long explanation in find_struct_field's function documentation. */
14f9c5c9 7360
4c4b4cd2 7361static struct value *
108d56a4 7362ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7363 struct type *type)
14f9c5c9
AS
7364{
7365 int i;
828d5846 7366 int parent_offset = -1;
14f9c5c9 7367
5b4ee69b 7368 type = ada_check_typedef (type);
52ce6436 7369 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7370 {
0d5cff50 7371 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7372
7373 if (t_field_name == NULL)
4c4b4cd2 7374 continue;
14f9c5c9 7375
828d5846
XR
7376 else if (ada_is_parent_field (type, i))
7377 {
7378 /* This is a field pointing us to the parent type of a tagged
7379 type. As hinted in this function's documentation, we give
7380 preference to fields in the current record first, so what
7381 we do here is just record the index of this field before
7382 we skip it. If it turns out we couldn't find our field
7383 in the current record, then we'll get back to it and search
7384 inside it whether the field might exist in the parent. */
7385
7386 parent_offset = i;
7387 continue;
7388 }
7389
14f9c5c9 7390 else if (field_name_match (t_field_name, name))
4c4b4cd2 7391 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7392
7393 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7394 {
0963b4bd 7395 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7396 ada_search_struct_field (name, arg,
7397 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7398 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7399
4c4b4cd2
PH
7400 if (v != NULL)
7401 return v;
7402 }
14f9c5c9
AS
7403
7404 else if (ada_is_variant_part (type, i))
4c4b4cd2 7405 {
0963b4bd 7406 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7407 int j;
5b4ee69b
MS
7408 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7409 i));
4c4b4cd2
PH
7410 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7411
52ce6436 7412 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7413 {
0963b4bd
MS
7414 struct value *v = ada_search_struct_field /* Force line
7415 break. */
06d5cf63
JB
7416 (name, arg,
7417 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7418 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7419
4c4b4cd2
PH
7420 if (v != NULL)
7421 return v;
7422 }
7423 }
14f9c5c9 7424 }
828d5846
XR
7425
7426 /* Field not found so far. If this is a tagged type which
7427 has a parent, try finding that field in the parent now. */
7428
7429 if (parent_offset != -1)
7430 {
7431 struct value *v = ada_search_struct_field (
7432 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7433 TYPE_FIELD_TYPE (type, parent_offset));
7434
7435 if (v != NULL)
7436 return v;
7437 }
7438
14f9c5c9
AS
7439 return NULL;
7440}
d2e4a39e 7441
52ce6436
PH
7442static struct value *ada_index_struct_field_1 (int *, struct value *,
7443 int, struct type *);
7444
7445
7446/* Return field #INDEX in ARG, where the index is that returned by
7447 * find_struct_field through its INDEX_P argument. Adjust the address
7448 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7449 * If found, return value, else return NULL. */
52ce6436
PH
7450
7451static struct value *
7452ada_index_struct_field (int index, struct value *arg, int offset,
7453 struct type *type)
7454{
7455 return ada_index_struct_field_1 (&index, arg, offset, type);
7456}
7457
7458
7459/* Auxiliary function for ada_index_struct_field. Like
7460 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7461 * *INDEX_P. */
52ce6436
PH
7462
7463static struct value *
7464ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7465 struct type *type)
7466{
7467 int i;
7468 type = ada_check_typedef (type);
7469
7470 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7471 {
7472 if (TYPE_FIELD_NAME (type, i) == NULL)
7473 continue;
7474 else if (ada_is_wrapper_field (type, i))
7475 {
0963b4bd 7476 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7477 ada_index_struct_field_1 (index_p, arg,
7478 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7479 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7480
52ce6436
PH
7481 if (v != NULL)
7482 return v;
7483 }
7484
7485 else if (ada_is_variant_part (type, i))
7486 {
7487 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7488 find_struct_field. */
52ce6436
PH
7489 error (_("Cannot assign this kind of variant record"));
7490 }
7491 else if (*index_p == 0)
7492 return ada_value_primitive_field (arg, offset, i, type);
7493 else
7494 *index_p -= 1;
7495 }
7496 return NULL;
7497}
7498
4c4b4cd2
PH
7499/* Given ARG, a value of type (pointer or reference to a)*
7500 structure/union, extract the component named NAME from the ultimate
7501 target structure/union and return it as a value with its
f5938064 7502 appropriate type.
14f9c5c9 7503
4c4b4cd2
PH
7504 The routine searches for NAME among all members of the structure itself
7505 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7506 (e.g., '_parent').
7507
03ee6b2e
PH
7508 If NO_ERR, then simply return NULL in case of error, rather than
7509 calling error. */
14f9c5c9 7510
d2e4a39e 7511struct value *
a121b7c1 7512ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7513{
4c4b4cd2 7514 struct type *t, *t1;
d2e4a39e 7515 struct value *v;
1f5d1570 7516 int check_tag;
14f9c5c9 7517
4c4b4cd2 7518 v = NULL;
df407dfe 7519 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7520 if (TYPE_CODE (t) == TYPE_CODE_REF)
7521 {
7522 t1 = TYPE_TARGET_TYPE (t);
7523 if (t1 == NULL)
03ee6b2e 7524 goto BadValue;
61ee279c 7525 t1 = ada_check_typedef (t1);
4c4b4cd2 7526 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7527 {
994b9211 7528 arg = coerce_ref (arg);
76a01679
JB
7529 t = t1;
7530 }
4c4b4cd2 7531 }
14f9c5c9 7532
4c4b4cd2
PH
7533 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7534 {
7535 t1 = TYPE_TARGET_TYPE (t);
7536 if (t1 == NULL)
03ee6b2e 7537 goto BadValue;
61ee279c 7538 t1 = ada_check_typedef (t1);
4c4b4cd2 7539 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7540 {
7541 arg = value_ind (arg);
7542 t = t1;
7543 }
4c4b4cd2 7544 else
76a01679 7545 break;
4c4b4cd2 7546 }
14f9c5c9 7547
4c4b4cd2 7548 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7549 goto BadValue;
14f9c5c9 7550
4c4b4cd2
PH
7551 if (t1 == t)
7552 v = ada_search_struct_field (name, arg, 0, t);
7553 else
7554 {
7555 int bit_offset, bit_size, byte_offset;
7556 struct type *field_type;
7557 CORE_ADDR address;
7558
76a01679 7559 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7560 address = value_address (ada_value_ind (arg));
4c4b4cd2 7561 else
b50d69b5 7562 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7563
828d5846
XR
7564 /* Check to see if this is a tagged type. We also need to handle
7565 the case where the type is a reference to a tagged type, but
7566 we have to be careful to exclude pointers to tagged types.
7567 The latter should be shown as usual (as a pointer), whereas
7568 a reference should mostly be transparent to the user. */
7569
7570 if (ada_is_tagged_type (t1, 0)
7571 || (TYPE_CODE (t1) == TYPE_CODE_REF
7572 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7573 {
7574 /* We first try to find the searched field in the current type.
7575 If not found then let's look in the fixed type. */
7576
7577 if (!find_struct_field (name, t1, 0,
7578 &field_type, &byte_offset, &bit_offset,
7579 &bit_size, NULL))
1f5d1570
JG
7580 check_tag = 1;
7581 else
7582 check_tag = 0;
828d5846
XR
7583 }
7584 else
1f5d1570
JG
7585 check_tag = 0;
7586
7587 /* Convert to fixed type in all cases, so that we have proper
7588 offsets to each field in unconstrained record types. */
7589 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7590 address, NULL, check_tag);
828d5846 7591
76a01679
JB
7592 if (find_struct_field (name, t1, 0,
7593 &field_type, &byte_offset, &bit_offset,
52ce6436 7594 &bit_size, NULL))
76a01679
JB
7595 {
7596 if (bit_size != 0)
7597 {
714e53ab
PH
7598 if (TYPE_CODE (t) == TYPE_CODE_REF)
7599 arg = ada_coerce_ref (arg);
7600 else
7601 arg = ada_value_ind (arg);
76a01679
JB
7602 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7603 bit_offset, bit_size,
7604 field_type);
7605 }
7606 else
f5938064 7607 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7608 }
7609 }
7610
03ee6b2e
PH
7611 if (v != NULL || no_err)
7612 return v;
7613 else
323e0a4a 7614 error (_("There is no member named %s."), name);
14f9c5c9 7615
03ee6b2e
PH
7616 BadValue:
7617 if (no_err)
7618 return NULL;
7619 else
0963b4bd
MS
7620 error (_("Attempt to extract a component of "
7621 "a value that is not a record."));
14f9c5c9
AS
7622}
7623
3b4de39c 7624/* Return a string representation of type TYPE. */
99bbb428 7625
3b4de39c 7626static std::string
99bbb428
PA
7627type_as_string (struct type *type)
7628{
d7e74731 7629 string_file tmp_stream;
99bbb428 7630
d7e74731 7631 type_print (type, "", &tmp_stream, -1);
99bbb428 7632
d7e74731 7633 return std::move (tmp_stream.string ());
99bbb428
PA
7634}
7635
14f9c5c9 7636/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7637 If DISPP is non-null, add its byte displacement from the beginning of a
7638 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7639 work for packed fields).
7640
7641 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7642 followed by "___".
14f9c5c9 7643
0963b4bd 7644 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7645 be a (pointer or reference)+ to a struct or union, and the
7646 ultimate target type will be searched.
14f9c5c9
AS
7647
7648 Looks recursively into variant clauses and parent types.
7649
828d5846
XR
7650 In the case of homonyms in the tagged types, please refer to the
7651 long explanation in find_struct_field's function documentation.
7652
4c4b4cd2
PH
7653 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7654 TYPE is not a type of the right kind. */
14f9c5c9 7655
4c4b4cd2 7656static struct type *
a121b7c1 7657ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7658 int noerr)
14f9c5c9
AS
7659{
7660 int i;
828d5846 7661 int parent_offset = -1;
14f9c5c9
AS
7662
7663 if (name == NULL)
7664 goto BadName;
7665
76a01679 7666 if (refok && type != NULL)
4c4b4cd2
PH
7667 while (1)
7668 {
61ee279c 7669 type = ada_check_typedef (type);
76a01679
JB
7670 if (TYPE_CODE (type) != TYPE_CODE_PTR
7671 && TYPE_CODE (type) != TYPE_CODE_REF)
7672 break;
7673 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7674 }
14f9c5c9 7675
76a01679 7676 if (type == NULL
1265e4aa
JB
7677 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7678 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7679 {
4c4b4cd2 7680 if (noerr)
76a01679 7681 return NULL;
99bbb428 7682
3b4de39c
PA
7683 error (_("Type %s is not a structure or union type"),
7684 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7685 }
7686
7687 type = to_static_fixed_type (type);
7688
7689 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7690 {
0d5cff50 7691 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7692 struct type *t;
d2e4a39e 7693
14f9c5c9 7694 if (t_field_name == NULL)
4c4b4cd2 7695 continue;
14f9c5c9 7696
828d5846
XR
7697 else if (ada_is_parent_field (type, i))
7698 {
7699 /* This is a field pointing us to the parent type of a tagged
7700 type. As hinted in this function's documentation, we give
7701 preference to fields in the current record first, so what
7702 we do here is just record the index of this field before
7703 we skip it. If it turns out we couldn't find our field
7704 in the current record, then we'll get back to it and search
7705 inside it whether the field might exist in the parent. */
7706
7707 parent_offset = i;
7708 continue;
7709 }
7710
14f9c5c9 7711 else if (field_name_match (t_field_name, name))
988f6b3d 7712 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7713
7714 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7715 {
4c4b4cd2 7716 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7717 0, 1);
4c4b4cd2 7718 if (t != NULL)
988f6b3d 7719 return t;
4c4b4cd2 7720 }
14f9c5c9
AS
7721
7722 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7723 {
7724 int j;
5b4ee69b
MS
7725 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7726 i));
4c4b4cd2
PH
7727
7728 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7729 {
b1f33ddd
JB
7730 /* FIXME pnh 2008/01/26: We check for a field that is
7731 NOT wrapped in a struct, since the compiler sometimes
7732 generates these for unchecked variant types. Revisit
0963b4bd 7733 if the compiler changes this practice. */
0d5cff50 7734 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7735
b1f33ddd
JB
7736 if (v_field_name != NULL
7737 && field_name_match (v_field_name, name))
460efde1 7738 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7739 else
0963b4bd
MS
7740 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7741 j),
988f6b3d 7742 name, 0, 1);
b1f33ddd 7743
4c4b4cd2 7744 if (t != NULL)
988f6b3d 7745 return t;
4c4b4cd2
PH
7746 }
7747 }
14f9c5c9
AS
7748
7749 }
7750
828d5846
XR
7751 /* Field not found so far. If this is a tagged type which
7752 has a parent, try finding that field in the parent now. */
7753
7754 if (parent_offset != -1)
7755 {
7756 struct type *t;
7757
7758 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7759 name, 0, 1);
7760 if (t != NULL)
7761 return t;
7762 }
7763
14f9c5c9 7764BadName:
d2e4a39e 7765 if (!noerr)
14f9c5c9 7766 {
2b2798cc 7767 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7768
7769 error (_("Type %s has no component named %s"),
3b4de39c 7770 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7771 }
7772
7773 return NULL;
7774}
7775
b1f33ddd
JB
7776/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7777 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7778 represents an unchecked union (that is, the variant part of a
0963b4bd 7779 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7780
7781static int
7782is_unchecked_variant (struct type *var_type, struct type *outer_type)
7783{
a121b7c1 7784 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7785
988f6b3d 7786 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7787}
7788
7789
14f9c5c9
AS
7790/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7791 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7792 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7793 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7794
d2e4a39e 7795int
ebf56fd3 7796ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7797 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7798{
7799 int others_clause;
7800 int i;
a121b7c1 7801 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7802 struct value *outer;
7803 struct value *discrim;
14f9c5c9
AS
7804 LONGEST discrim_val;
7805
012370f6
TT
7806 /* Using plain value_from_contents_and_address here causes problems
7807 because we will end up trying to resolve a type that is currently
7808 being constructed. */
7809 outer = value_from_contents_and_address_unresolved (outer_type,
7810 outer_valaddr, 0);
0c281816
JB
7811 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7812 if (discrim == NULL)
14f9c5c9 7813 return -1;
0c281816 7814 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7815
7816 others_clause = -1;
7817 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7818 {
7819 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7820 others_clause = i;
14f9c5c9 7821 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7822 return i;
14f9c5c9
AS
7823 }
7824
7825 return others_clause;
7826}
d2e4a39e 7827\f
14f9c5c9
AS
7828
7829
4c4b4cd2 7830 /* Dynamic-Sized Records */
14f9c5c9
AS
7831
7832/* Strategy: The type ostensibly attached to a value with dynamic size
7833 (i.e., a size that is not statically recorded in the debugging
7834 data) does not accurately reflect the size or layout of the value.
7835 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7836 conventional types that are constructed on the fly. */
14f9c5c9
AS
7837
7838/* There is a subtle and tricky problem here. In general, we cannot
7839 determine the size of dynamic records without its data. However,
7840 the 'struct value' data structure, which GDB uses to represent
7841 quantities in the inferior process (the target), requires the size
7842 of the type at the time of its allocation in order to reserve space
7843 for GDB's internal copy of the data. That's why the
7844 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7845 rather than struct value*s.
14f9c5c9
AS
7846
7847 However, GDB's internal history variables ($1, $2, etc.) are
7848 struct value*s containing internal copies of the data that are not, in
7849 general, the same as the data at their corresponding addresses in
7850 the target. Fortunately, the types we give to these values are all
7851 conventional, fixed-size types (as per the strategy described
7852 above), so that we don't usually have to perform the
7853 'to_fixed_xxx_type' conversions to look at their values.
7854 Unfortunately, there is one exception: if one of the internal
7855 history variables is an array whose elements are unconstrained
7856 records, then we will need to create distinct fixed types for each
7857 element selected. */
7858
7859/* The upshot of all of this is that many routines take a (type, host
7860 address, target address) triple as arguments to represent a value.
7861 The host address, if non-null, is supposed to contain an internal
7862 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7863 target at the target address. */
14f9c5c9
AS
7864
7865/* Assuming that VAL0 represents a pointer value, the result of
7866 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7867 dynamic-sized types. */
14f9c5c9 7868
d2e4a39e
AS
7869struct value *
7870ada_value_ind (struct value *val0)
14f9c5c9 7871{
c48db5ca 7872 struct value *val = value_ind (val0);
5b4ee69b 7873
b50d69b5
JG
7874 if (ada_is_tagged_type (value_type (val), 0))
7875 val = ada_tag_value_at_base_address (val);
7876
4c4b4cd2 7877 return ada_to_fixed_value (val);
14f9c5c9
AS
7878}
7879
7880/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7881 qualifiers on VAL0. */
7882
d2e4a39e
AS
7883static struct value *
7884ada_coerce_ref (struct value *val0)
7885{
df407dfe 7886 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7887 {
7888 struct value *val = val0;
5b4ee69b 7889
994b9211 7890 val = coerce_ref (val);
b50d69b5
JG
7891
7892 if (ada_is_tagged_type (value_type (val), 0))
7893 val = ada_tag_value_at_base_address (val);
7894
4c4b4cd2 7895 return ada_to_fixed_value (val);
d2e4a39e
AS
7896 }
7897 else
14f9c5c9
AS
7898 return val0;
7899}
7900
7901/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7902 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7903
7904static unsigned int
ebf56fd3 7905align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7906{
7907 return (off + alignment - 1) & ~(alignment - 1);
7908}
7909
4c4b4cd2 7910/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7911
7912static unsigned int
ebf56fd3 7913field_alignment (struct type *type, int f)
14f9c5c9 7914{
d2e4a39e 7915 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7916 int len;
14f9c5c9
AS
7917 int align_offset;
7918
64a1bf19
JB
7919 /* The field name should never be null, unless the debugging information
7920 is somehow malformed. In this case, we assume the field does not
7921 require any alignment. */
7922 if (name == NULL)
7923 return 1;
7924
7925 len = strlen (name);
7926
4c4b4cd2
PH
7927 if (!isdigit (name[len - 1]))
7928 return 1;
14f9c5c9 7929
d2e4a39e 7930 if (isdigit (name[len - 2]))
14f9c5c9
AS
7931 align_offset = len - 2;
7932 else
7933 align_offset = len - 1;
7934
61012eef 7935 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7936 return TARGET_CHAR_BIT;
7937
4c4b4cd2
PH
7938 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7939}
7940
852dff6c 7941/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7942
852dff6c
JB
7943static struct symbol *
7944ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7945{
7946 struct symbol *sym;
7947
7948 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7949 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7950 return sym;
7951
4186eb54
KS
7952 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7953 return sym;
14f9c5c9
AS
7954}
7955
dddfab26
UW
7956/* Find a type named NAME. Ignores ambiguity. This routine will look
7957 solely for types defined by debug info, it will not search the GDB
7958 primitive types. */
4c4b4cd2 7959
852dff6c 7960static struct type *
ebf56fd3 7961ada_find_any_type (const char *name)
14f9c5c9 7962{
852dff6c 7963 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7964
14f9c5c9 7965 if (sym != NULL)
dddfab26 7966 return SYMBOL_TYPE (sym);
14f9c5c9 7967
dddfab26 7968 return NULL;
14f9c5c9
AS
7969}
7970
739593e0
JB
7971/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7972 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7973 symbol, in which case it is returned. Otherwise, this looks for
7974 symbols whose name is that of NAME_SYM suffixed with "___XR".
7975 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7976
7977struct symbol *
270140bd 7978ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7979{
739593e0 7980 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7981 struct symbol *sym;
7982
739593e0
JB
7983 if (strstr (name, "___XR") != NULL)
7984 return name_sym;
7985
aeb5907d
JB
7986 sym = find_old_style_renaming_symbol (name, block);
7987
7988 if (sym != NULL)
7989 return sym;
7990
0963b4bd 7991 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7992 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7993 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7994 return sym;
7995 else
7996 return NULL;
7997}
7998
7999static struct symbol *
270140bd 8000find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 8001{
7f0df278 8002 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
8003 char *rename;
8004
8005 if (function_sym != NULL)
8006 {
8007 /* If the symbol is defined inside a function, NAME is not fully
8008 qualified. This means we need to prepend the function name
8009 as well as adding the ``___XR'' suffix to build the name of
8010 the associated renaming symbol. */
0d5cff50 8011 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
8012 /* Function names sometimes contain suffixes used
8013 for instance to qualify nested subprograms. When building
8014 the XR type name, we need to make sure that this suffix is
8015 not included. So do not include any suffix in the function
8016 name length below. */
69fadcdf 8017 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
8018 const int rename_len = function_name_len + 2 /* "__" */
8019 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 8020
529cad9c 8021 /* Strip the suffix if necessary. */
69fadcdf
JB
8022 ada_remove_trailing_digits (function_name, &function_name_len);
8023 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8024 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 8025
4c4b4cd2
PH
8026 /* Library-level functions are a special case, as GNAT adds
8027 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 8028 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
8029 have this prefix, so we need to skip this prefix if present. */
8030 if (function_name_len > 5 /* "_ada_" */
8031 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
8032 {
8033 function_name += 5;
8034 function_name_len -= 5;
8035 }
4c4b4cd2
PH
8036
8037 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
8038 strncpy (rename, function_name, function_name_len);
8039 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8040 "__%s___XR", name);
4c4b4cd2
PH
8041 }
8042 else
8043 {
8044 const int rename_len = strlen (name) + 6;
5b4ee69b 8045
4c4b4cd2 8046 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 8047 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
8048 }
8049
852dff6c 8050 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
8051}
8052
14f9c5c9 8053/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 8054 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 8055 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
8056 otherwise return 0. */
8057
14f9c5c9 8058int
d2e4a39e 8059ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
8060{
8061 if (type1 == NULL)
8062 return 1;
8063 else if (type0 == NULL)
8064 return 0;
8065 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8066 return 1;
8067 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8068 return 0;
4c4b4cd2
PH
8069 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8070 return 1;
ad82864c 8071 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8072 return 1;
4c4b4cd2
PH
8073 else if (ada_is_array_descriptor_type (type0)
8074 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8075 return 1;
aeb5907d
JB
8076 else
8077 {
a737d952
TT
8078 const char *type0_name = TYPE_NAME (type0);
8079 const char *type1_name = TYPE_NAME (type1);
aeb5907d
JB
8080
8081 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8082 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8083 return 1;
8084 }
14f9c5c9
AS
8085 return 0;
8086}
8087
e86ca25f
TT
8088/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
8089 null. */
4c4b4cd2 8090
0d5cff50 8091const char *
d2e4a39e 8092ada_type_name (struct type *type)
14f9c5c9 8093{
d2e4a39e 8094 if (type == NULL)
14f9c5c9 8095 return NULL;
e86ca25f 8096 return TYPE_NAME (type);
14f9c5c9
AS
8097}
8098
b4ba55a1
JB
8099/* Search the list of "descriptive" types associated to TYPE for a type
8100 whose name is NAME. */
8101
8102static struct type *
8103find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8104{
931e5bc3 8105 struct type *result, *tmp;
b4ba55a1 8106
c6044dd1
JB
8107 if (ada_ignore_descriptive_types_p)
8108 return NULL;
8109
b4ba55a1
JB
8110 /* If there no descriptive-type info, then there is no parallel type
8111 to be found. */
8112 if (!HAVE_GNAT_AUX_INFO (type))
8113 return NULL;
8114
8115 result = TYPE_DESCRIPTIVE_TYPE (type);
8116 while (result != NULL)
8117 {
0d5cff50 8118 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8119
8120 if (result_name == NULL)
8121 {
8122 warning (_("unexpected null name on descriptive type"));
8123 return NULL;
8124 }
8125
8126 /* If the names match, stop. */
8127 if (strcmp (result_name, name) == 0)
8128 break;
8129
8130 /* Otherwise, look at the next item on the list, if any. */
8131 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8132 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8133 else
8134 tmp = NULL;
8135
8136 /* If not found either, try after having resolved the typedef. */
8137 if (tmp != NULL)
8138 result = tmp;
b4ba55a1 8139 else
931e5bc3 8140 {
f168693b 8141 result = check_typedef (result);
931e5bc3
JG
8142 if (HAVE_GNAT_AUX_INFO (result))
8143 result = TYPE_DESCRIPTIVE_TYPE (result);
8144 else
8145 result = NULL;
8146 }
b4ba55a1
JB
8147 }
8148
8149 /* If we didn't find a match, see whether this is a packed array. With
8150 older compilers, the descriptive type information is either absent or
8151 irrelevant when it comes to packed arrays so the above lookup fails.
8152 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8153 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8154 return ada_find_any_type (name);
8155
8156 return result;
8157}
8158
8159/* Find a parallel type to TYPE with the specified NAME, using the
8160 descriptive type taken from the debugging information, if available,
8161 and otherwise using the (slower) name-based method. */
8162
8163static struct type *
8164ada_find_parallel_type_with_name (struct type *type, const char *name)
8165{
8166 struct type *result = NULL;
8167
8168 if (HAVE_GNAT_AUX_INFO (type))
8169 result = find_parallel_type_by_descriptive_type (type, name);
8170 else
8171 result = ada_find_any_type (name);
8172
8173 return result;
8174}
8175
8176/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8177 SUFFIX to the name of TYPE. */
14f9c5c9 8178
d2e4a39e 8179struct type *
ebf56fd3 8180ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8181{
0d5cff50 8182 char *name;
fe978cb0 8183 const char *type_name = ada_type_name (type);
14f9c5c9 8184 int len;
d2e4a39e 8185
fe978cb0 8186 if (type_name == NULL)
14f9c5c9
AS
8187 return NULL;
8188
fe978cb0 8189 len = strlen (type_name);
14f9c5c9 8190
b4ba55a1 8191 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8192
fe978cb0 8193 strcpy (name, type_name);
14f9c5c9
AS
8194 strcpy (name + len, suffix);
8195
b4ba55a1 8196 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8197}
8198
14f9c5c9 8199/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8200 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8201
d2e4a39e
AS
8202static struct type *
8203dynamic_template_type (struct type *type)
14f9c5c9 8204{
61ee279c 8205 type = ada_check_typedef (type);
14f9c5c9
AS
8206
8207 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8208 || ada_type_name (type) == NULL)
14f9c5c9 8209 return NULL;
d2e4a39e 8210 else
14f9c5c9
AS
8211 {
8212 int len = strlen (ada_type_name (type));
5b4ee69b 8213
4c4b4cd2
PH
8214 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8215 return type;
14f9c5c9 8216 else
4c4b4cd2 8217 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8218 }
8219}
8220
8221/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8222 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8223
d2e4a39e
AS
8224static int
8225is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8226{
8227 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8228
d2e4a39e 8229 return name != NULL
14f9c5c9
AS
8230 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8231 && strstr (name, "___XVL") != NULL;
8232}
8233
4c4b4cd2
PH
8234/* The index of the variant field of TYPE, or -1 if TYPE does not
8235 represent a variant record type. */
14f9c5c9 8236
d2e4a39e 8237static int
4c4b4cd2 8238variant_field_index (struct type *type)
14f9c5c9
AS
8239{
8240 int f;
8241
4c4b4cd2
PH
8242 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8243 return -1;
8244
8245 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8246 {
8247 if (ada_is_variant_part (type, f))
8248 return f;
8249 }
8250 return -1;
14f9c5c9
AS
8251}
8252
4c4b4cd2
PH
8253/* A record type with no fields. */
8254
d2e4a39e 8255static struct type *
fe978cb0 8256empty_record (struct type *templ)
14f9c5c9 8257{
fe978cb0 8258 struct type *type = alloc_type_copy (templ);
5b4ee69b 8259
14f9c5c9
AS
8260 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8261 TYPE_NFIELDS (type) = 0;
8262 TYPE_FIELDS (type) = NULL;
b1f33ddd 8263 INIT_CPLUS_SPECIFIC (type);
14f9c5c9 8264 TYPE_NAME (type) = "<empty>";
14f9c5c9
AS
8265 TYPE_LENGTH (type) = 0;
8266 return type;
8267}
8268
8269/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8270 the value of type TYPE at VALADDR or ADDRESS (see comments at
8271 the beginning of this section) VAL according to GNAT conventions.
8272 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8273 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8274 an outer-level type (i.e., as opposed to a branch of a variant.) A
8275 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8276 of the variant.
14f9c5c9 8277
4c4b4cd2
PH
8278 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8279 length are not statically known are discarded. As a consequence,
8280 VALADDR, ADDRESS and DVAL0 are ignored.
8281
8282 NOTE: Limitations: For now, we assume that dynamic fields and
8283 variants occupy whole numbers of bytes. However, they need not be
8284 byte-aligned. */
8285
8286struct type *
10a2c479 8287ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8288 const gdb_byte *valaddr,
4c4b4cd2
PH
8289 CORE_ADDR address, struct value *dval0,
8290 int keep_dynamic_fields)
14f9c5c9 8291{
d2e4a39e
AS
8292 struct value *mark = value_mark ();
8293 struct value *dval;
8294 struct type *rtype;
14f9c5c9 8295 int nfields, bit_len;
4c4b4cd2 8296 int variant_field;
14f9c5c9 8297 long off;
d94e4f4f 8298 int fld_bit_len;
14f9c5c9
AS
8299 int f;
8300
4c4b4cd2
PH
8301 /* Compute the number of fields in this record type that are going
8302 to be processed: unless keep_dynamic_fields, this includes only
8303 fields whose position and length are static will be processed. */
8304 if (keep_dynamic_fields)
8305 nfields = TYPE_NFIELDS (type);
8306 else
8307 {
8308 nfields = 0;
76a01679 8309 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8310 && !ada_is_variant_part (type, nfields)
8311 && !is_dynamic_field (type, nfields))
8312 nfields++;
8313 }
8314
e9bb382b 8315 rtype = alloc_type_copy (type);
14f9c5c9
AS
8316 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8317 INIT_CPLUS_SPECIFIC (rtype);
8318 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8319 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8320 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8321 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8322 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8323 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8324
d2e4a39e
AS
8325 off = 0;
8326 bit_len = 0;
4c4b4cd2
PH
8327 variant_field = -1;
8328
14f9c5c9
AS
8329 for (f = 0; f < nfields; f += 1)
8330 {
6c038f32
PH
8331 off = align_value (off, field_alignment (type, f))
8332 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8333 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8334 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8335
d2e4a39e 8336 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8337 {
8338 variant_field = f;
d94e4f4f 8339 fld_bit_len = 0;
4c4b4cd2 8340 }
14f9c5c9 8341 else if (is_dynamic_field (type, f))
4c4b4cd2 8342 {
284614f0
JB
8343 const gdb_byte *field_valaddr = valaddr;
8344 CORE_ADDR field_address = address;
8345 struct type *field_type =
8346 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8347
4c4b4cd2 8348 if (dval0 == NULL)
b5304971
JG
8349 {
8350 /* rtype's length is computed based on the run-time
8351 value of discriminants. If the discriminants are not
8352 initialized, the type size may be completely bogus and
0963b4bd 8353 GDB may fail to allocate a value for it. So check the
b5304971 8354 size first before creating the value. */
c1b5a1a6 8355 ada_ensure_varsize_limit (rtype);
012370f6
TT
8356 /* Using plain value_from_contents_and_address here
8357 causes problems because we will end up trying to
8358 resolve a type that is currently being
8359 constructed. */
8360 dval = value_from_contents_and_address_unresolved (rtype,
8361 valaddr,
8362 address);
9f1f738a 8363 rtype = value_type (dval);
b5304971 8364 }
4c4b4cd2
PH
8365 else
8366 dval = dval0;
8367
284614f0
JB
8368 /* If the type referenced by this field is an aligner type, we need
8369 to unwrap that aligner type, because its size might not be set.
8370 Keeping the aligner type would cause us to compute the wrong
8371 size for this field, impacting the offset of the all the fields
8372 that follow this one. */
8373 if (ada_is_aligner_type (field_type))
8374 {
8375 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8376
8377 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8378 field_address = cond_offset_target (field_address, field_offset);
8379 field_type = ada_aligned_type (field_type);
8380 }
8381
8382 field_valaddr = cond_offset_host (field_valaddr,
8383 off / TARGET_CHAR_BIT);
8384 field_address = cond_offset_target (field_address,
8385 off / TARGET_CHAR_BIT);
8386
8387 /* Get the fixed type of the field. Note that, in this case,
8388 we do not want to get the real type out of the tag: if
8389 the current field is the parent part of a tagged record,
8390 we will get the tag of the object. Clearly wrong: the real
8391 type of the parent is not the real type of the child. We
8392 would end up in an infinite loop. */
8393 field_type = ada_get_base_type (field_type);
8394 field_type = ada_to_fixed_type (field_type, field_valaddr,
8395 field_address, dval, 0);
27f2a97b
JB
8396 /* If the field size is already larger than the maximum
8397 object size, then the record itself will necessarily
8398 be larger than the maximum object size. We need to make
8399 this check now, because the size might be so ridiculously
8400 large (due to an uninitialized variable in the inferior)
8401 that it would cause an overflow when adding it to the
8402 record size. */
c1b5a1a6 8403 ada_ensure_varsize_limit (field_type);
284614f0
JB
8404
8405 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8406 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8407 /* The multiplication can potentially overflow. But because
8408 the field length has been size-checked just above, and
8409 assuming that the maximum size is a reasonable value,
8410 an overflow should not happen in practice. So rather than
8411 adding overflow recovery code to this already complex code,
8412 we just assume that it's not going to happen. */
d94e4f4f 8413 fld_bit_len =
4c4b4cd2
PH
8414 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8415 }
14f9c5c9 8416 else
4c4b4cd2 8417 {
5ded5331
JB
8418 /* Note: If this field's type is a typedef, it is important
8419 to preserve the typedef layer.
8420
8421 Otherwise, we might be transforming a typedef to a fat
8422 pointer (encoding a pointer to an unconstrained array),
8423 into a basic fat pointer (encoding an unconstrained
8424 array). As both types are implemented using the same
8425 structure, the typedef is the only clue which allows us
8426 to distinguish between the two options. Stripping it
8427 would prevent us from printing this field appropriately. */
8428 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8429 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8430 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8431 fld_bit_len =
4c4b4cd2
PH
8432 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8433 else
5ded5331
JB
8434 {
8435 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8436
8437 /* We need to be careful of typedefs when computing
8438 the length of our field. If this is a typedef,
8439 get the length of the target type, not the length
8440 of the typedef. */
8441 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8442 field_type = ada_typedef_target_type (field_type);
8443
8444 fld_bit_len =
8445 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8446 }
4c4b4cd2 8447 }
14f9c5c9 8448 if (off + fld_bit_len > bit_len)
4c4b4cd2 8449 bit_len = off + fld_bit_len;
d94e4f4f 8450 off += fld_bit_len;
4c4b4cd2
PH
8451 TYPE_LENGTH (rtype) =
8452 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8453 }
4c4b4cd2
PH
8454
8455 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8456 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8457 the record. This can happen in the presence of representation
8458 clauses. */
8459 if (variant_field >= 0)
8460 {
8461 struct type *branch_type;
8462
8463 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8464
8465 if (dval0 == NULL)
9f1f738a 8466 {
012370f6
TT
8467 /* Using plain value_from_contents_and_address here causes
8468 problems because we will end up trying to resolve a type
8469 that is currently being constructed. */
8470 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8471 address);
9f1f738a
SA
8472 rtype = value_type (dval);
8473 }
4c4b4cd2
PH
8474 else
8475 dval = dval0;
8476
8477 branch_type =
8478 to_fixed_variant_branch_type
8479 (TYPE_FIELD_TYPE (type, variant_field),
8480 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8481 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8482 if (branch_type == NULL)
8483 {
8484 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8485 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8486 TYPE_NFIELDS (rtype) -= 1;
8487 }
8488 else
8489 {
8490 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8491 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8492 fld_bit_len =
8493 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8494 TARGET_CHAR_BIT;
8495 if (off + fld_bit_len > bit_len)
8496 bit_len = off + fld_bit_len;
8497 TYPE_LENGTH (rtype) =
8498 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8499 }
8500 }
8501
714e53ab
PH
8502 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8503 should contain the alignment of that record, which should be a strictly
8504 positive value. If null or negative, then something is wrong, most
8505 probably in the debug info. In that case, we don't round up the size
0963b4bd 8506 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8507 the current RTYPE length might be good enough for our purposes. */
8508 if (TYPE_LENGTH (type) <= 0)
8509 {
323e0a4a 8510 if (TYPE_NAME (rtype))
cc1defb1
KS
8511 warning (_("Invalid type size for `%s' detected: %s."),
8512 TYPE_NAME (rtype), pulongest (TYPE_LENGTH (type)));
323e0a4a 8513 else
cc1defb1
KS
8514 warning (_("Invalid type size for <unnamed> detected: %s."),
8515 pulongest (TYPE_LENGTH (type)));
714e53ab
PH
8516 }
8517 else
8518 {
8519 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8520 TYPE_LENGTH (type));
8521 }
14f9c5c9
AS
8522
8523 value_free_to_mark (mark);
d2e4a39e 8524 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8525 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8526 return rtype;
8527}
8528
4c4b4cd2
PH
8529/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8530 of 1. */
14f9c5c9 8531
d2e4a39e 8532static struct type *
fc1a4b47 8533template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8534 CORE_ADDR address, struct value *dval0)
8535{
8536 return ada_template_to_fixed_record_type_1 (type, valaddr,
8537 address, dval0, 1);
8538}
8539
8540/* An ordinary record type in which ___XVL-convention fields and
8541 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8542 static approximations, containing all possible fields. Uses
8543 no runtime values. Useless for use in values, but that's OK,
8544 since the results are used only for type determinations. Works on both
8545 structs and unions. Representation note: to save space, we memorize
8546 the result of this function in the TYPE_TARGET_TYPE of the
8547 template type. */
8548
8549static struct type *
8550template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8551{
8552 struct type *type;
8553 int nfields;
8554 int f;
8555
9e195661
PMR
8556 /* No need no do anything if the input type is already fixed. */
8557 if (TYPE_FIXED_INSTANCE (type0))
8558 return type0;
8559
8560 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8561 if (TYPE_TARGET_TYPE (type0) != NULL)
8562 return TYPE_TARGET_TYPE (type0);
8563
9e195661 8564 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8565 type = type0;
9e195661
PMR
8566 nfields = TYPE_NFIELDS (type0);
8567
8568 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8569 recompute all over next time. */
8570 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8571
8572 for (f = 0; f < nfields; f += 1)
8573 {
460efde1 8574 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8575 struct type *new_type;
14f9c5c9 8576
4c4b4cd2 8577 if (is_dynamic_field (type0, f))
460efde1
JB
8578 {
8579 field_type = ada_check_typedef (field_type);
8580 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8581 }
14f9c5c9 8582 else
f192137b 8583 new_type = static_unwrap_type (field_type);
9e195661
PMR
8584
8585 if (new_type != field_type)
8586 {
8587 /* Clone TYPE0 only the first time we get a new field type. */
8588 if (type == type0)
8589 {
8590 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8591 TYPE_CODE (type) = TYPE_CODE (type0);
8592 INIT_CPLUS_SPECIFIC (type);
8593 TYPE_NFIELDS (type) = nfields;
8594 TYPE_FIELDS (type) = (struct field *)
8595 TYPE_ALLOC (type, nfields * sizeof (struct field));
8596 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8597 sizeof (struct field) * nfields);
8598 TYPE_NAME (type) = ada_type_name (type0);
9e195661
PMR
8599 TYPE_FIXED_INSTANCE (type) = 1;
8600 TYPE_LENGTH (type) = 0;
8601 }
8602 TYPE_FIELD_TYPE (type, f) = new_type;
8603 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8604 }
14f9c5c9 8605 }
9e195661 8606
14f9c5c9
AS
8607 return type;
8608}
8609
4c4b4cd2 8610/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8611 whose address in memory is ADDRESS, returns a revision of TYPE,
8612 which should be a non-dynamic-sized record, in which the variant
8613 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8614 for discriminant values in DVAL0, which can be NULL if the record
8615 contains the necessary discriminant values. */
8616
d2e4a39e 8617static struct type *
fc1a4b47 8618to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8619 CORE_ADDR address, struct value *dval0)
14f9c5c9 8620{
d2e4a39e 8621 struct value *mark = value_mark ();
4c4b4cd2 8622 struct value *dval;
d2e4a39e 8623 struct type *rtype;
14f9c5c9
AS
8624 struct type *branch_type;
8625 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8626 int variant_field = variant_field_index (type);
14f9c5c9 8627
4c4b4cd2 8628 if (variant_field == -1)
14f9c5c9
AS
8629 return type;
8630
4c4b4cd2 8631 if (dval0 == NULL)
9f1f738a
SA
8632 {
8633 dval = value_from_contents_and_address (type, valaddr, address);
8634 type = value_type (dval);
8635 }
4c4b4cd2
PH
8636 else
8637 dval = dval0;
8638
e9bb382b 8639 rtype = alloc_type_copy (type);
14f9c5c9 8640 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8641 INIT_CPLUS_SPECIFIC (rtype);
8642 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8643 TYPE_FIELDS (rtype) =
8644 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8645 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8646 sizeof (struct field) * nfields);
14f9c5c9 8647 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8648 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8649 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8650
4c4b4cd2
PH
8651 branch_type = to_fixed_variant_branch_type
8652 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8653 cond_offset_host (valaddr,
4c4b4cd2
PH
8654 TYPE_FIELD_BITPOS (type, variant_field)
8655 / TARGET_CHAR_BIT),
d2e4a39e 8656 cond_offset_target (address,
4c4b4cd2
PH
8657 TYPE_FIELD_BITPOS (type, variant_field)
8658 / TARGET_CHAR_BIT), dval);
d2e4a39e 8659 if (branch_type == NULL)
14f9c5c9 8660 {
4c4b4cd2 8661 int f;
5b4ee69b 8662
4c4b4cd2
PH
8663 for (f = variant_field + 1; f < nfields; f += 1)
8664 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8665 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8666 }
8667 else
8668 {
4c4b4cd2
PH
8669 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8670 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8671 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8672 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8673 }
4c4b4cd2 8674 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8675
4c4b4cd2 8676 value_free_to_mark (mark);
14f9c5c9
AS
8677 return rtype;
8678}
8679
8680/* An ordinary record type (with fixed-length fields) that describes
8681 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8682 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8683 should be in DVAL, a record value; it may be NULL if the object
8684 at ADDR itself contains any necessary discriminant values.
8685 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8686 values from the record are needed. Except in the case that DVAL,
8687 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8688 unchecked) is replaced by a particular branch of the variant.
8689
8690 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8691 is questionable and may be removed. It can arise during the
8692 processing of an unconstrained-array-of-record type where all the
8693 variant branches have exactly the same size. This is because in
8694 such cases, the compiler does not bother to use the XVS convention
8695 when encoding the record. I am currently dubious of this
8696 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8697
d2e4a39e 8698static struct type *
fc1a4b47 8699to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8700 CORE_ADDR address, struct value *dval)
14f9c5c9 8701{
d2e4a39e 8702 struct type *templ_type;
14f9c5c9 8703
876cecd0 8704 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8705 return type0;
8706
d2e4a39e 8707 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8708
8709 if (templ_type != NULL)
8710 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8711 else if (variant_field_index (type0) >= 0)
8712 {
8713 if (dval == NULL && valaddr == NULL && address == 0)
8714 return type0;
8715 return to_record_with_fixed_variant_part (type0, valaddr, address,
8716 dval);
8717 }
14f9c5c9
AS
8718 else
8719 {
876cecd0 8720 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8721 return type0;
8722 }
8723
8724}
8725
8726/* An ordinary record type (with fixed-length fields) that describes
8727 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8728 union type. Any necessary discriminants' values should be in DVAL,
8729 a record value. That is, this routine selects the appropriate
8730 branch of the union at ADDR according to the discriminant value
b1f33ddd 8731 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8732 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8733
d2e4a39e 8734static struct type *
fc1a4b47 8735to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8736 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8737{
8738 int which;
d2e4a39e
AS
8739 struct type *templ_type;
8740 struct type *var_type;
14f9c5c9
AS
8741
8742 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8743 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8744 else
14f9c5c9
AS
8745 var_type = var_type0;
8746
8747 templ_type = ada_find_parallel_type (var_type, "___XVU");
8748
8749 if (templ_type != NULL)
8750 var_type = templ_type;
8751
b1f33ddd
JB
8752 if (is_unchecked_variant (var_type, value_type (dval)))
8753 return var_type0;
d2e4a39e
AS
8754 which =
8755 ada_which_variant_applies (var_type,
0fd88904 8756 value_type (dval), value_contents (dval));
14f9c5c9
AS
8757
8758 if (which < 0)
e9bb382b 8759 return empty_record (var_type);
14f9c5c9 8760 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8761 return to_fixed_record_type
d2e4a39e
AS
8762 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8763 valaddr, address, dval);
4c4b4cd2 8764 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8765 return
8766 to_fixed_record_type
8767 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8768 else
8769 return TYPE_FIELD_TYPE (var_type, which);
8770}
8771
8908fca5
JB
8772/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8773 ENCODING_TYPE, a type following the GNAT conventions for discrete
8774 type encodings, only carries redundant information. */
8775
8776static int
8777ada_is_redundant_range_encoding (struct type *range_type,
8778 struct type *encoding_type)
8779{
108d56a4 8780 const char *bounds_str;
8908fca5
JB
8781 int n;
8782 LONGEST lo, hi;
8783
8784 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8785
005e2509
JB
8786 if (TYPE_CODE (get_base_type (range_type))
8787 != TYPE_CODE (get_base_type (encoding_type)))
8788 {
8789 /* The compiler probably used a simple base type to describe
8790 the range type instead of the range's actual base type,
8791 expecting us to get the real base type from the encoding
8792 anyway. In this situation, the encoding cannot be ignored
8793 as redundant. */
8794 return 0;
8795 }
8796
8908fca5
JB
8797 if (is_dynamic_type (range_type))
8798 return 0;
8799
8800 if (TYPE_NAME (encoding_type) == NULL)
8801 return 0;
8802
8803 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8804 if (bounds_str == NULL)
8805 return 0;
8806
8807 n = 8; /* Skip "___XDLU_". */
8808 if (!ada_scan_number (bounds_str, n, &lo, &n))
8809 return 0;
8810 if (TYPE_LOW_BOUND (range_type) != lo)
8811 return 0;
8812
8813 n += 2; /* Skip the "__" separator between the two bounds. */
8814 if (!ada_scan_number (bounds_str, n, &hi, &n))
8815 return 0;
8816 if (TYPE_HIGH_BOUND (range_type) != hi)
8817 return 0;
8818
8819 return 1;
8820}
8821
8822/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8823 a type following the GNAT encoding for describing array type
8824 indices, only carries redundant information. */
8825
8826static int
8827ada_is_redundant_index_type_desc (struct type *array_type,
8828 struct type *desc_type)
8829{
8830 struct type *this_layer = check_typedef (array_type);
8831 int i;
8832
8833 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8834 {
8835 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8836 TYPE_FIELD_TYPE (desc_type, i)))
8837 return 0;
8838 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8839 }
8840
8841 return 1;
8842}
8843
14f9c5c9
AS
8844/* Assuming that TYPE0 is an array type describing the type of a value
8845 at ADDR, and that DVAL describes a record containing any
8846 discriminants used in TYPE0, returns a type for the value that
8847 contains no dynamic components (that is, no components whose sizes
8848 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8849 true, gives an error message if the resulting type's size is over
4c4b4cd2 8850 varsize_limit. */
14f9c5c9 8851
d2e4a39e
AS
8852static struct type *
8853to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8854 int ignore_too_big)
14f9c5c9 8855{
d2e4a39e
AS
8856 struct type *index_type_desc;
8857 struct type *result;
ad82864c 8858 int constrained_packed_array_p;
931e5bc3 8859 static const char *xa_suffix = "___XA";
14f9c5c9 8860
b0dd7688 8861 type0 = ada_check_typedef (type0);
284614f0 8862 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8863 return type0;
14f9c5c9 8864
ad82864c
JB
8865 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8866 if (constrained_packed_array_p)
8867 type0 = decode_constrained_packed_array_type (type0);
284614f0 8868
931e5bc3
JG
8869 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8870
8871 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8872 encoding suffixed with 'P' may still be generated. If so,
8873 it should be used to find the XA type. */
8874
8875 if (index_type_desc == NULL)
8876 {
1da0522e 8877 const char *type_name = ada_type_name (type0);
931e5bc3 8878
1da0522e 8879 if (type_name != NULL)
931e5bc3 8880 {
1da0522e 8881 const int len = strlen (type_name);
931e5bc3
JG
8882 char *name = (char *) alloca (len + strlen (xa_suffix));
8883
1da0522e 8884 if (type_name[len - 1] == 'P')
931e5bc3 8885 {
1da0522e 8886 strcpy (name, type_name);
931e5bc3
JG
8887 strcpy (name + len - 1, xa_suffix);
8888 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8889 }
8890 }
8891 }
8892
28c85d6c 8893 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8894 if (index_type_desc != NULL
8895 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8896 {
8897 /* Ignore this ___XA parallel type, as it does not bring any
8898 useful information. This allows us to avoid creating fixed
8899 versions of the array's index types, which would be identical
8900 to the original ones. This, in turn, can also help avoid
8901 the creation of fixed versions of the array itself. */
8902 index_type_desc = NULL;
8903 }
8904
14f9c5c9
AS
8905 if (index_type_desc == NULL)
8906 {
61ee279c 8907 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8908
14f9c5c9 8909 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8910 depend on the contents of the array in properly constructed
8911 debugging data. */
529cad9c
PH
8912 /* Create a fixed version of the array element type.
8913 We're not providing the address of an element here,
e1d5a0d2 8914 and thus the actual object value cannot be inspected to do
529cad9c
PH
8915 the conversion. This should not be a problem, since arrays of
8916 unconstrained objects are not allowed. In particular, all
8917 the elements of an array of a tagged type should all be of
8918 the same type specified in the debugging info. No need to
8919 consult the object tag. */
1ed6ede0 8920 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8921
284614f0
JB
8922 /* Make sure we always create a new array type when dealing with
8923 packed array types, since we're going to fix-up the array
8924 type length and element bitsize a little further down. */
ad82864c 8925 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8926 result = type0;
14f9c5c9 8927 else
e9bb382b 8928 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8929 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8930 }
8931 else
8932 {
8933 int i;
8934 struct type *elt_type0;
8935
8936 elt_type0 = type0;
8937 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8938 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8939
8940 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8941 depend on the contents of the array in properly constructed
8942 debugging data. */
529cad9c
PH
8943 /* Create a fixed version of the array element type.
8944 We're not providing the address of an element here,
e1d5a0d2 8945 and thus the actual object value cannot be inspected to do
529cad9c
PH
8946 the conversion. This should not be a problem, since arrays of
8947 unconstrained objects are not allowed. In particular, all
8948 the elements of an array of a tagged type should all be of
8949 the same type specified in the debugging info. No need to
8950 consult the object tag. */
1ed6ede0
JB
8951 result =
8952 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8953
8954 elt_type0 = type0;
14f9c5c9 8955 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8956 {
8957 struct type *range_type =
28c85d6c 8958 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8959
e9bb382b 8960 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8961 result, range_type);
1ce677a4 8962 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8963 }
d2e4a39e 8964 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8965 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8966 }
8967
2e6fda7d
JB
8968 /* We want to preserve the type name. This can be useful when
8969 trying to get the type name of a value that has already been
8970 printed (for instance, if the user did "print VAR; whatis $". */
8971 TYPE_NAME (result) = TYPE_NAME (type0);
8972
ad82864c 8973 if (constrained_packed_array_p)
284614f0
JB
8974 {
8975 /* So far, the resulting type has been created as if the original
8976 type was a regular (non-packed) array type. As a result, the
8977 bitsize of the array elements needs to be set again, and the array
8978 length needs to be recomputed based on that bitsize. */
8979 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8980 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8981
8982 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8983 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8984 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8985 TYPE_LENGTH (result)++;
8986 }
8987
876cecd0 8988 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8989 return result;
d2e4a39e 8990}
14f9c5c9
AS
8991
8992
8993/* A standard type (containing no dynamically sized components)
8994 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8995 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8996 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8997 ADDRESS or in VALADDR contains these discriminants.
8998
1ed6ede0
JB
8999 If CHECK_TAG is not null, in the case of tagged types, this function
9000 attempts to locate the object's tag and use it to compute the actual
9001 type. However, when ADDRESS is null, we cannot use it to determine the
9002 location of the tag, and therefore compute the tagged type's actual type.
9003 So we return the tagged type without consulting the tag. */
529cad9c 9004
f192137b
JB
9005static struct type *
9006ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 9007 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 9008{
61ee279c 9009 type = ada_check_typedef (type);
d2e4a39e
AS
9010 switch (TYPE_CODE (type))
9011 {
9012 default:
14f9c5c9 9013 return type;
d2e4a39e 9014 case TYPE_CODE_STRUCT:
4c4b4cd2 9015 {
76a01679 9016 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
9017 struct type *fixed_record_type =
9018 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 9019
529cad9c
PH
9020 /* If STATIC_TYPE is a tagged type and we know the object's address,
9021 then we can determine its tag, and compute the object's actual
0963b4bd 9022 type from there. Note that we have to use the fixed record
1ed6ede0
JB
9023 type (the parent part of the record may have dynamic fields
9024 and the way the location of _tag is expressed may depend on
9025 them). */
529cad9c 9026
1ed6ede0 9027 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 9028 {
b50d69b5
JG
9029 struct value *tag =
9030 value_tag_from_contents_and_address
9031 (fixed_record_type,
9032 valaddr,
9033 address);
9034 struct type *real_type = type_from_tag (tag);
9035 struct value *obj =
9036 value_from_contents_and_address (fixed_record_type,
9037 valaddr,
9038 address);
9f1f738a 9039 fixed_record_type = value_type (obj);
76a01679 9040 if (real_type != NULL)
b50d69b5
JG
9041 return to_fixed_record_type
9042 (real_type, NULL,
9043 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 9044 }
4af88198
JB
9045
9046 /* Check to see if there is a parallel ___XVZ variable.
9047 If there is, then it provides the actual size of our type. */
9048 else if (ada_type_name (fixed_record_type) != NULL)
9049 {
0d5cff50 9050 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
9051 char *xvz_name
9052 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 9053 bool xvz_found = false;
4af88198
JB
9054 LONGEST size;
9055
88c15c34 9056 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
eccab96d
JB
9057 TRY
9058 {
9059 xvz_found = get_int_var_value (xvz_name, size);
9060 }
9061 CATCH (except, RETURN_MASK_ERROR)
9062 {
9063 /* We found the variable, but somehow failed to read
9064 its value. Rethrow the same error, but with a little
9065 bit more information, to help the user understand
9066 what went wrong (Eg: the variable might have been
9067 optimized out). */
9068 throw_error (except.error,
9069 _("unable to read value of %s (%s)"),
3d6e9d23 9070 xvz_name, except.what ());
eccab96d
JB
9071 }
9072 END_CATCH
9073
9074 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
9075 {
9076 fixed_record_type = copy_type (fixed_record_type);
9077 TYPE_LENGTH (fixed_record_type) = size;
9078
9079 /* The FIXED_RECORD_TYPE may have be a stub. We have
9080 observed this when the debugging info is STABS, and
9081 apparently it is something that is hard to fix.
9082
9083 In practice, we don't need the actual type definition
9084 at all, because the presence of the XVZ variable allows us
9085 to assume that there must be a XVS type as well, which we
9086 should be able to use later, when we need the actual type
9087 definition.
9088
9089 In the meantime, pretend that the "fixed" type we are
9090 returning is NOT a stub, because this can cause trouble
9091 when using this type to create new types targeting it.
9092 Indeed, the associated creation routines often check
9093 whether the target type is a stub and will try to replace
0963b4bd 9094 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9095 might cause the new type to have the wrong size too.
9096 Consider the case of an array, for instance, where the size
9097 of the array is computed from the number of elements in
9098 our array multiplied by the size of its element. */
9099 TYPE_STUB (fixed_record_type) = 0;
9100 }
9101 }
1ed6ede0 9102 return fixed_record_type;
4c4b4cd2 9103 }
d2e4a39e 9104 case TYPE_CODE_ARRAY:
4c4b4cd2 9105 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9106 case TYPE_CODE_UNION:
9107 if (dval == NULL)
4c4b4cd2 9108 return type;
d2e4a39e 9109 else
4c4b4cd2 9110 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9111 }
14f9c5c9
AS
9112}
9113
f192137b
JB
9114/* The same as ada_to_fixed_type_1, except that it preserves the type
9115 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9116
9117 The typedef layer needs be preserved in order to differentiate between
9118 arrays and array pointers when both types are implemented using the same
9119 fat pointer. In the array pointer case, the pointer is encoded as
9120 a typedef of the pointer type. For instance, considering:
9121
9122 type String_Access is access String;
9123 S1 : String_Access := null;
9124
9125 To the debugger, S1 is defined as a typedef of type String. But
9126 to the user, it is a pointer. So if the user tries to print S1,
9127 we should not dereference the array, but print the array address
9128 instead.
9129
9130 If we didn't preserve the typedef layer, we would lose the fact that
9131 the type is to be presented as a pointer (needs de-reference before
9132 being printed). And we would also use the source-level type name. */
f192137b
JB
9133
9134struct type *
9135ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9136 CORE_ADDR address, struct value *dval, int check_tag)
9137
9138{
9139 struct type *fixed_type =
9140 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9141
96dbd2c1
JB
9142 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9143 then preserve the typedef layer.
9144
9145 Implementation note: We can only check the main-type portion of
9146 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9147 from TYPE now returns a type that has the same instance flags
9148 as TYPE. For instance, if TYPE is a "typedef const", and its
9149 target type is a "struct", then the typedef elimination will return
9150 a "const" version of the target type. See check_typedef for more
9151 details about how the typedef layer elimination is done.
9152
9153 brobecker/2010-11-19: It seems to me that the only case where it is
9154 useful to preserve the typedef layer is when dealing with fat pointers.
9155 Perhaps, we could add a check for that and preserve the typedef layer
9156 only in that situation. But this seems unecessary so far, probably
9157 because we call check_typedef/ada_check_typedef pretty much everywhere.
9158 */
f192137b 9159 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9160 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9161 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9162 return type;
9163
9164 return fixed_type;
9165}
9166
14f9c5c9 9167/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9168 TYPE0, but based on no runtime data. */
14f9c5c9 9169
d2e4a39e
AS
9170static struct type *
9171to_static_fixed_type (struct type *type0)
14f9c5c9 9172{
d2e4a39e 9173 struct type *type;
14f9c5c9
AS
9174
9175 if (type0 == NULL)
9176 return NULL;
9177
876cecd0 9178 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9179 return type0;
9180
61ee279c 9181 type0 = ada_check_typedef (type0);
d2e4a39e 9182
14f9c5c9
AS
9183 switch (TYPE_CODE (type0))
9184 {
9185 default:
9186 return type0;
9187 case TYPE_CODE_STRUCT:
9188 type = dynamic_template_type (type0);
d2e4a39e 9189 if (type != NULL)
4c4b4cd2
PH
9190 return template_to_static_fixed_type (type);
9191 else
9192 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9193 case TYPE_CODE_UNION:
9194 type = ada_find_parallel_type (type0, "___XVU");
9195 if (type != NULL)
4c4b4cd2
PH
9196 return template_to_static_fixed_type (type);
9197 else
9198 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9199 }
9200}
9201
4c4b4cd2
PH
9202/* A static approximation of TYPE with all type wrappers removed. */
9203
d2e4a39e
AS
9204static struct type *
9205static_unwrap_type (struct type *type)
14f9c5c9
AS
9206{
9207 if (ada_is_aligner_type (type))
9208 {
61ee279c 9209 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9210 if (ada_type_name (type1) == NULL)
4c4b4cd2 9211 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9212
9213 return static_unwrap_type (type1);
9214 }
d2e4a39e 9215 else
14f9c5c9 9216 {
d2e4a39e 9217 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9218
d2e4a39e 9219 if (raw_real_type == type)
4c4b4cd2 9220 return type;
14f9c5c9 9221 else
4c4b4cd2 9222 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9223 }
9224}
9225
9226/* In some cases, incomplete and private types require
4c4b4cd2 9227 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9228 type Foo;
9229 type FooP is access Foo;
9230 V: FooP;
9231 type Foo is array ...;
4c4b4cd2 9232 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9233 cross-references to such types, we instead substitute for FooP a
9234 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9235 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9236
9237/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9238 exists, otherwise TYPE. */
9239
d2e4a39e 9240struct type *
61ee279c 9241ada_check_typedef (struct type *type)
14f9c5c9 9242{
727e3d2e
JB
9243 if (type == NULL)
9244 return NULL;
9245
736ade86
XR
9246 /* If our type is an access to an unconstrained array, which is encoded
9247 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
720d1a40
JB
9248 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9249 what allows us to distinguish between fat pointers that represent
9250 array types, and fat pointers that represent array access types
9251 (in both cases, the compiler implements them as fat pointers). */
736ade86 9252 if (ada_is_access_to_unconstrained_array (type))
720d1a40
JB
9253 return type;
9254
f168693b 9255 type = check_typedef (type);
14f9c5c9 9256 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9257 || !TYPE_STUB (type)
e86ca25f 9258 || TYPE_NAME (type) == NULL)
14f9c5c9 9259 return type;
d2e4a39e 9260 else
14f9c5c9 9261 {
e86ca25f 9262 const char *name = TYPE_NAME (type);
d2e4a39e 9263 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9264
05e522ef
JB
9265 if (type1 == NULL)
9266 return type;
9267
9268 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9269 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9270 types, only for the typedef-to-array types). If that's the case,
9271 strip the typedef layer. */
9272 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9273 type1 = ada_check_typedef (type1);
9274
9275 return type1;
14f9c5c9
AS
9276 }
9277}
9278
9279/* A value representing the data at VALADDR/ADDRESS as described by
9280 type TYPE0, but with a standard (static-sized) type that correctly
9281 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9282 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9283 creation of struct values]. */
14f9c5c9 9284
4c4b4cd2
PH
9285static struct value *
9286ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9287 struct value *val0)
14f9c5c9 9288{
1ed6ede0 9289 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9290
14f9c5c9
AS
9291 if (type == type0 && val0 != NULL)
9292 return val0;
cc0e770c
JB
9293
9294 if (VALUE_LVAL (val0) != lval_memory)
9295 {
9296 /* Our value does not live in memory; it could be a convenience
9297 variable, for instance. Create a not_lval value using val0's
9298 contents. */
9299 return value_from_contents (type, value_contents (val0));
9300 }
9301
9302 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9303}
9304
9305/* A value representing VAL, but with a standard (static-sized) type
9306 that correctly describes it. Does not necessarily create a new
9307 value. */
9308
0c3acc09 9309struct value *
4c4b4cd2
PH
9310ada_to_fixed_value (struct value *val)
9311{
c48db5ca 9312 val = unwrap_value (val);
d8ce9127 9313 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
c48db5ca 9314 return val;
14f9c5c9 9315}
d2e4a39e 9316\f
14f9c5c9 9317
14f9c5c9
AS
9318/* Attributes */
9319
4c4b4cd2
PH
9320/* Table mapping attribute numbers to names.
9321 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9322
d2e4a39e 9323static const char *attribute_names[] = {
14f9c5c9
AS
9324 "<?>",
9325
d2e4a39e 9326 "first",
14f9c5c9
AS
9327 "last",
9328 "length",
9329 "image",
14f9c5c9
AS
9330 "max",
9331 "min",
4c4b4cd2
PH
9332 "modulus",
9333 "pos",
9334 "size",
9335 "tag",
14f9c5c9 9336 "val",
14f9c5c9
AS
9337 0
9338};
9339
d2e4a39e 9340const char *
4c4b4cd2 9341ada_attribute_name (enum exp_opcode n)
14f9c5c9 9342{
4c4b4cd2
PH
9343 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9344 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9345 else
9346 return attribute_names[0];
9347}
9348
4c4b4cd2 9349/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9350
4c4b4cd2
PH
9351static LONGEST
9352pos_atr (struct value *arg)
14f9c5c9 9353{
24209737
PH
9354 struct value *val = coerce_ref (arg);
9355 struct type *type = value_type (val);
aa715135 9356 LONGEST result;
14f9c5c9 9357
d2e4a39e 9358 if (!discrete_type_p (type))
323e0a4a 9359 error (_("'POS only defined on discrete types"));
14f9c5c9 9360
aa715135
JG
9361 if (!discrete_position (type, value_as_long (val), &result))
9362 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9363
aa715135 9364 return result;
4c4b4cd2
PH
9365}
9366
9367static struct value *
3cb382c9 9368value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9369{
3cb382c9 9370 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9371}
9372
4c4b4cd2 9373/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9374
d2e4a39e
AS
9375static struct value *
9376value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9377{
d2e4a39e 9378 if (!discrete_type_p (type))
323e0a4a 9379 error (_("'VAL only defined on discrete types"));
df407dfe 9380 if (!integer_type_p (value_type (arg)))
323e0a4a 9381 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9382
9383 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9384 {
9385 long pos = value_as_long (arg);
5b4ee69b 9386
14f9c5c9 9387 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9388 error (_("argument to 'VAL out of range"));
14e75d8e 9389 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9390 }
9391 else
9392 return value_from_longest (type, value_as_long (arg));
9393}
14f9c5c9 9394\f
d2e4a39e 9395
4c4b4cd2 9396 /* Evaluation */
14f9c5c9 9397
4c4b4cd2
PH
9398/* True if TYPE appears to be an Ada character type.
9399 [At the moment, this is true only for Character and Wide_Character;
9400 It is a heuristic test that could stand improvement]. */
14f9c5c9 9401
d2e4a39e
AS
9402int
9403ada_is_character_type (struct type *type)
14f9c5c9 9404{
7b9f71f2
JB
9405 const char *name;
9406
9407 /* If the type code says it's a character, then assume it really is,
9408 and don't check any further. */
9409 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9410 return 1;
9411
9412 /* Otherwise, assume it's a character type iff it is a discrete type
9413 with a known character type name. */
9414 name = ada_type_name (type);
9415 return (name != NULL
9416 && (TYPE_CODE (type) == TYPE_CODE_INT
9417 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9418 && (strcmp (name, "character") == 0
9419 || strcmp (name, "wide_character") == 0
5a517ebd 9420 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9421 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9422}
9423
4c4b4cd2 9424/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9425
9426int
ebf56fd3 9427ada_is_string_type (struct type *type)
14f9c5c9 9428{
61ee279c 9429 type = ada_check_typedef (type);
d2e4a39e 9430 if (type != NULL
14f9c5c9 9431 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9432 && (ada_is_simple_array_type (type)
9433 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9434 && ada_array_arity (type) == 1)
9435 {
9436 struct type *elttype = ada_array_element_type (type, 1);
9437
9438 return ada_is_character_type (elttype);
9439 }
d2e4a39e 9440 else
14f9c5c9
AS
9441 return 0;
9442}
9443
5bf03f13
JB
9444/* The compiler sometimes provides a parallel XVS type for a given
9445 PAD type. Normally, it is safe to follow the PAD type directly,
9446 but older versions of the compiler have a bug that causes the offset
9447 of its "F" field to be wrong. Following that field in that case
9448 would lead to incorrect results, but this can be worked around
9449 by ignoring the PAD type and using the associated XVS type instead.
9450
9451 Set to True if the debugger should trust the contents of PAD types.
9452 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9453static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9454
9455/* True if TYPE is a struct type introduced by the compiler to force the
9456 alignment of a value. Such types have a single field with a
4c4b4cd2 9457 distinctive name. */
14f9c5c9
AS
9458
9459int
ebf56fd3 9460ada_is_aligner_type (struct type *type)
14f9c5c9 9461{
61ee279c 9462 type = ada_check_typedef (type);
714e53ab 9463
5bf03f13 9464 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9465 return 0;
9466
14f9c5c9 9467 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9468 && TYPE_NFIELDS (type) == 1
9469 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9470}
9471
9472/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9473 the parallel type. */
14f9c5c9 9474
d2e4a39e
AS
9475struct type *
9476ada_get_base_type (struct type *raw_type)
14f9c5c9 9477{
d2e4a39e
AS
9478 struct type *real_type_namer;
9479 struct type *raw_real_type;
14f9c5c9
AS
9480
9481 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9482 return raw_type;
9483
284614f0
JB
9484 if (ada_is_aligner_type (raw_type))
9485 /* The encoding specifies that we should always use the aligner type.
9486 So, even if this aligner type has an associated XVS type, we should
9487 simply ignore it.
9488
9489 According to the compiler gurus, an XVS type parallel to an aligner
9490 type may exist because of a stabs limitation. In stabs, aligner
9491 types are empty because the field has a variable-sized type, and
9492 thus cannot actually be used as an aligner type. As a result,
9493 we need the associated parallel XVS type to decode the type.
9494 Since the policy in the compiler is to not change the internal
9495 representation based on the debugging info format, we sometimes
9496 end up having a redundant XVS type parallel to the aligner type. */
9497 return raw_type;
9498
14f9c5c9 9499 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9500 if (real_type_namer == NULL
14f9c5c9
AS
9501 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9502 || TYPE_NFIELDS (real_type_namer) != 1)
9503 return raw_type;
9504
f80d3ff2
JB
9505 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9506 {
9507 /* This is an older encoding form where the base type needs to be
9508 looked up by name. We prefer the newer enconding because it is
9509 more efficient. */
9510 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9511 if (raw_real_type == NULL)
9512 return raw_type;
9513 else
9514 return raw_real_type;
9515 }
9516
9517 /* The field in our XVS type is a reference to the base type. */
9518 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9519}
14f9c5c9 9520
4c4b4cd2 9521/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9522
d2e4a39e
AS
9523struct type *
9524ada_aligned_type (struct type *type)
14f9c5c9
AS
9525{
9526 if (ada_is_aligner_type (type))
9527 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9528 else
9529 return ada_get_base_type (type);
9530}
9531
9532
9533/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9534 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9535
fc1a4b47
AC
9536const gdb_byte *
9537ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9538{
d2e4a39e 9539 if (ada_is_aligner_type (type))
14f9c5c9 9540 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9541 valaddr +
9542 TYPE_FIELD_BITPOS (type,
9543 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9544 else
9545 return valaddr;
9546}
9547
4c4b4cd2
PH
9548
9549
14f9c5c9 9550/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9551 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9552const char *
9553ada_enum_name (const char *name)
14f9c5c9 9554{
4c4b4cd2
PH
9555 static char *result;
9556 static size_t result_len = 0;
e6a959d6 9557 const char *tmp;
14f9c5c9 9558
4c4b4cd2
PH
9559 /* First, unqualify the enumeration name:
9560 1. Search for the last '.' character. If we find one, then skip
177b42fe 9561 all the preceding characters, the unqualified name starts
76a01679 9562 right after that dot.
4c4b4cd2 9563 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9564 translates dots into "__". Search forward for double underscores,
9565 but stop searching when we hit an overloading suffix, which is
9566 of the form "__" followed by digits. */
4c4b4cd2 9567
c3e5cd34
PH
9568 tmp = strrchr (name, '.');
9569 if (tmp != NULL)
4c4b4cd2
PH
9570 name = tmp + 1;
9571 else
14f9c5c9 9572 {
4c4b4cd2
PH
9573 while ((tmp = strstr (name, "__")) != NULL)
9574 {
9575 if (isdigit (tmp[2]))
9576 break;
9577 else
9578 name = tmp + 2;
9579 }
14f9c5c9
AS
9580 }
9581
9582 if (name[0] == 'Q')
9583 {
14f9c5c9 9584 int v;
5b4ee69b 9585
14f9c5c9 9586 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9587 {
9588 if (sscanf (name + 2, "%x", &v) != 1)
9589 return name;
9590 }
14f9c5c9 9591 else
4c4b4cd2 9592 return name;
14f9c5c9 9593
4c4b4cd2 9594 GROW_VECT (result, result_len, 16);
14f9c5c9 9595 if (isascii (v) && isprint (v))
88c15c34 9596 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9597 else if (name[1] == 'U')
88c15c34 9598 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9599 else
88c15c34 9600 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9601
9602 return result;
9603 }
d2e4a39e 9604 else
4c4b4cd2 9605 {
c3e5cd34
PH
9606 tmp = strstr (name, "__");
9607 if (tmp == NULL)
9608 tmp = strstr (name, "$");
9609 if (tmp != NULL)
4c4b4cd2
PH
9610 {
9611 GROW_VECT (result, result_len, tmp - name + 1);
9612 strncpy (result, name, tmp - name);
9613 result[tmp - name] = '\0';
9614 return result;
9615 }
9616
9617 return name;
9618 }
14f9c5c9
AS
9619}
9620
14f9c5c9
AS
9621/* Evaluate the subexpression of EXP starting at *POS as for
9622 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9623 expression. */
14f9c5c9 9624
d2e4a39e
AS
9625static struct value *
9626evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9627{
4b27a620 9628 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9629}
9630
9631/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9632 value it wraps. */
14f9c5c9 9633
d2e4a39e
AS
9634static struct value *
9635unwrap_value (struct value *val)
14f9c5c9 9636{
df407dfe 9637 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9638
14f9c5c9
AS
9639 if (ada_is_aligner_type (type))
9640 {
de4d072f 9641 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9642 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9643
14f9c5c9 9644 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9645 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9646
9647 return unwrap_value (v);
9648 }
d2e4a39e 9649 else
14f9c5c9 9650 {
d2e4a39e 9651 struct type *raw_real_type =
61ee279c 9652 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9653
5bf03f13
JB
9654 /* If there is no parallel XVS or XVE type, then the value is
9655 already unwrapped. Return it without further modification. */
9656 if ((type == raw_real_type)
9657 && ada_find_parallel_type (type, "___XVE") == NULL)
9658 return val;
14f9c5c9 9659
d2e4a39e 9660 return
4c4b4cd2
PH
9661 coerce_unspec_val_to_type
9662 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9663 value_address (val),
1ed6ede0 9664 NULL, 1));
14f9c5c9
AS
9665 }
9666}
d2e4a39e
AS
9667
9668static struct value *
50eff16b 9669cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9670{
50eff16b
UW
9671 struct value *scale = ada_scaling_factor (value_type (arg));
9672 arg = value_cast (value_type (scale), arg);
14f9c5c9 9673
50eff16b
UW
9674 arg = value_binop (arg, scale, BINOP_MUL);
9675 return value_cast (type, arg);
14f9c5c9
AS
9676}
9677
d2e4a39e 9678static struct value *
50eff16b 9679cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9680{
50eff16b
UW
9681 if (type == value_type (arg))
9682 return arg;
5b4ee69b 9683
50eff16b
UW
9684 struct value *scale = ada_scaling_factor (type);
9685 if (ada_is_fixed_point_type (value_type (arg)))
9686 arg = cast_from_fixed (value_type (scale), arg);
9687 else
9688 arg = value_cast (value_type (scale), arg);
9689
9690 arg = value_binop (arg, scale, BINOP_DIV);
9691 return value_cast (type, arg);
14f9c5c9
AS
9692}
9693
d99dcf51
JB
9694/* Given two array types T1 and T2, return nonzero iff both arrays
9695 contain the same number of elements. */
9696
9697static int
9698ada_same_array_size_p (struct type *t1, struct type *t2)
9699{
9700 LONGEST lo1, hi1, lo2, hi2;
9701
9702 /* Get the array bounds in order to verify that the size of
9703 the two arrays match. */
9704 if (!get_array_bounds (t1, &lo1, &hi1)
9705 || !get_array_bounds (t2, &lo2, &hi2))
9706 error (_("unable to determine array bounds"));
9707
9708 /* To make things easier for size comparison, normalize a bit
9709 the case of empty arrays by making sure that the difference
9710 between upper bound and lower bound is always -1. */
9711 if (lo1 > hi1)
9712 hi1 = lo1 - 1;
9713 if (lo2 > hi2)
9714 hi2 = lo2 - 1;
9715
9716 return (hi1 - lo1 == hi2 - lo2);
9717}
9718
9719/* Assuming that VAL is an array of integrals, and TYPE represents
9720 an array with the same number of elements, but with wider integral
9721 elements, return an array "casted" to TYPE. In practice, this
9722 means that the returned array is built by casting each element
9723 of the original array into TYPE's (wider) element type. */
9724
9725static struct value *
9726ada_promote_array_of_integrals (struct type *type, struct value *val)
9727{
9728 struct type *elt_type = TYPE_TARGET_TYPE (type);
9729 LONGEST lo, hi;
9730 struct value *res;
9731 LONGEST i;
9732
9733 /* Verify that both val and type are arrays of scalars, and
9734 that the size of val's elements is smaller than the size
9735 of type's element. */
9736 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9737 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9738 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9739 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9740 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9741 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9742
9743 if (!get_array_bounds (type, &lo, &hi))
9744 error (_("unable to determine array bounds"));
9745
9746 res = allocate_value (type);
9747
9748 /* Promote each array element. */
9749 for (i = 0; i < hi - lo + 1; i++)
9750 {
9751 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9752
9753 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9754 value_contents_all (elt), TYPE_LENGTH (elt_type));
9755 }
9756
9757 return res;
9758}
9759
4c4b4cd2
PH
9760/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9761 return the converted value. */
9762
d2e4a39e
AS
9763static struct value *
9764coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9765{
df407dfe 9766 struct type *type2 = value_type (val);
5b4ee69b 9767
14f9c5c9
AS
9768 if (type == type2)
9769 return val;
9770
61ee279c
PH
9771 type2 = ada_check_typedef (type2);
9772 type = ada_check_typedef (type);
14f9c5c9 9773
d2e4a39e
AS
9774 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9775 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9776 {
9777 val = ada_value_ind (val);
df407dfe 9778 type2 = value_type (val);
14f9c5c9
AS
9779 }
9780
d2e4a39e 9781 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9782 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9783 {
d99dcf51
JB
9784 if (!ada_same_array_size_p (type, type2))
9785 error (_("cannot assign arrays of different length"));
9786
9787 if (is_integral_type (TYPE_TARGET_TYPE (type))
9788 && is_integral_type (TYPE_TARGET_TYPE (type2))
9789 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9790 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9791 {
9792 /* Allow implicit promotion of the array elements to
9793 a wider type. */
9794 return ada_promote_array_of_integrals (type, val);
9795 }
9796
9797 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9798 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9799 error (_("Incompatible types in assignment"));
04624583 9800 deprecated_set_value_type (val, type);
14f9c5c9 9801 }
d2e4a39e 9802 return val;
14f9c5c9
AS
9803}
9804
4c4b4cd2
PH
9805static struct value *
9806ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9807{
9808 struct value *val;
9809 struct type *type1, *type2;
9810 LONGEST v, v1, v2;
9811
994b9211
AC
9812 arg1 = coerce_ref (arg1);
9813 arg2 = coerce_ref (arg2);
18af8284
JB
9814 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9815 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9816
76a01679
JB
9817 if (TYPE_CODE (type1) != TYPE_CODE_INT
9818 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9819 return value_binop (arg1, arg2, op);
9820
76a01679 9821 switch (op)
4c4b4cd2
PH
9822 {
9823 case BINOP_MOD:
9824 case BINOP_DIV:
9825 case BINOP_REM:
9826 break;
9827 default:
9828 return value_binop (arg1, arg2, op);
9829 }
9830
9831 v2 = value_as_long (arg2);
9832 if (v2 == 0)
323e0a4a 9833 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9834
9835 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9836 return value_binop (arg1, arg2, op);
9837
9838 v1 = value_as_long (arg1);
9839 switch (op)
9840 {
9841 case BINOP_DIV:
9842 v = v1 / v2;
76a01679
JB
9843 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9844 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9845 break;
9846 case BINOP_REM:
9847 v = v1 % v2;
76a01679
JB
9848 if (v * v1 < 0)
9849 v -= v2;
4c4b4cd2
PH
9850 break;
9851 default:
9852 /* Should not reach this point. */
9853 v = 0;
9854 }
9855
9856 val = allocate_value (type1);
990a07ab 9857 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9858 TYPE_LENGTH (value_type (val)),
9859 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9860 return val;
9861}
9862
9863static int
9864ada_value_equal (struct value *arg1, struct value *arg2)
9865{
df407dfe
AC
9866 if (ada_is_direct_array_type (value_type (arg1))
9867 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9868 {
79e8fcaa
JB
9869 struct type *arg1_type, *arg2_type;
9870
f58b38bf
JB
9871 /* Automatically dereference any array reference before
9872 we attempt to perform the comparison. */
9873 arg1 = ada_coerce_ref (arg1);
9874 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9875
4c4b4cd2
PH
9876 arg1 = ada_coerce_to_simple_array (arg1);
9877 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9878
9879 arg1_type = ada_check_typedef (value_type (arg1));
9880 arg2_type = ada_check_typedef (value_type (arg2));
9881
9882 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9883 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9884 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9885 /* FIXME: The following works only for types whose
76a01679
JB
9886 representations use all bits (no padding or undefined bits)
9887 and do not have user-defined equality. */
79e8fcaa
JB
9888 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9889 && memcmp (value_contents (arg1), value_contents (arg2),
9890 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9891 }
9892 return value_equal (arg1, arg2);
9893}
9894
52ce6436
PH
9895/* Total number of component associations in the aggregate starting at
9896 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9897 OP_AGGREGATE. */
52ce6436
PH
9898
9899static int
9900num_component_specs (struct expression *exp, int pc)
9901{
9902 int n, m, i;
5b4ee69b 9903
52ce6436
PH
9904 m = exp->elts[pc + 1].longconst;
9905 pc += 3;
9906 n = 0;
9907 for (i = 0; i < m; i += 1)
9908 {
9909 switch (exp->elts[pc].opcode)
9910 {
9911 default:
9912 n += 1;
9913 break;
9914 case OP_CHOICES:
9915 n += exp->elts[pc + 1].longconst;
9916 break;
9917 }
9918 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9919 }
9920 return n;
9921}
9922
9923/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9924 component of LHS (a simple array or a record), updating *POS past
9925 the expression, assuming that LHS is contained in CONTAINER. Does
9926 not modify the inferior's memory, nor does it modify LHS (unless
9927 LHS == CONTAINER). */
9928
9929static void
9930assign_component (struct value *container, struct value *lhs, LONGEST index,
9931 struct expression *exp, int *pos)
9932{
9933 struct value *mark = value_mark ();
9934 struct value *elt;
0e2da9f0 9935 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9936
0e2da9f0 9937 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9938 {
22601c15
UW
9939 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9940 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9941
52ce6436
PH
9942 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9943 }
9944 else
9945 {
9946 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9947 elt = ada_to_fixed_value (elt);
52ce6436
PH
9948 }
9949
9950 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9951 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9952 else
9953 value_assign_to_component (container, elt,
9954 ada_evaluate_subexp (NULL, exp, pos,
9955 EVAL_NORMAL));
9956
9957 value_free_to_mark (mark);
9958}
9959
9960/* Assuming that LHS represents an lvalue having a record or array
9961 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9962 of that aggregate's value to LHS, advancing *POS past the
9963 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9964 lvalue containing LHS (possibly LHS itself). Does not modify
9965 the inferior's memory, nor does it modify the contents of
0963b4bd 9966 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9967
9968static struct value *
9969assign_aggregate (struct value *container,
9970 struct value *lhs, struct expression *exp,
9971 int *pos, enum noside noside)
9972{
9973 struct type *lhs_type;
9974 int n = exp->elts[*pos+1].longconst;
9975 LONGEST low_index, high_index;
9976 int num_specs;
9977 LONGEST *indices;
9978 int max_indices, num_indices;
52ce6436 9979 int i;
52ce6436
PH
9980
9981 *pos += 3;
9982 if (noside != EVAL_NORMAL)
9983 {
52ce6436
PH
9984 for (i = 0; i < n; i += 1)
9985 ada_evaluate_subexp (NULL, exp, pos, noside);
9986 return container;
9987 }
9988
9989 container = ada_coerce_ref (container);
9990 if (ada_is_direct_array_type (value_type (container)))
9991 container = ada_coerce_to_simple_array (container);
9992 lhs = ada_coerce_ref (lhs);
9993 if (!deprecated_value_modifiable (lhs))
9994 error (_("Left operand of assignment is not a modifiable lvalue."));
9995
0e2da9f0 9996 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9997 if (ada_is_direct_array_type (lhs_type))
9998 {
9999 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 10000 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
10001 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10002 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
10003 }
10004 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10005 {
10006 low_index = 0;
10007 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
10008 }
10009 else
10010 error (_("Left-hand side must be array or record."));
10011
10012 num_specs = num_component_specs (exp, *pos - 3);
10013 max_indices = 4 * num_specs + 4;
8d749320 10014 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
10015 indices[0] = indices[1] = low_index - 1;
10016 indices[2] = indices[3] = high_index + 1;
10017 num_indices = 4;
10018
10019 for (i = 0; i < n; i += 1)
10020 {
10021 switch (exp->elts[*pos].opcode)
10022 {
1fbf5ada
JB
10023 case OP_CHOICES:
10024 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10025 &num_indices, max_indices,
10026 low_index, high_index);
10027 break;
10028 case OP_POSITIONAL:
10029 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
10030 &num_indices, max_indices,
10031 low_index, high_index);
1fbf5ada
JB
10032 break;
10033 case OP_OTHERS:
10034 if (i != n-1)
10035 error (_("Misplaced 'others' clause"));
10036 aggregate_assign_others (container, lhs, exp, pos, indices,
10037 num_indices, low_index, high_index);
10038 break;
10039 default:
10040 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
10041 }
10042 }
10043
10044 return container;
10045}
10046
10047/* Assign into the component of LHS indexed by the OP_POSITIONAL
10048 construct at *POS, updating *POS past the construct, given that
10049 the positions are relative to lower bound LOW, where HIGH is the
10050 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10051 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 10052 assign_aggregate. */
52ce6436
PH
10053static void
10054aggregate_assign_positional (struct value *container,
10055 struct value *lhs, struct expression *exp,
10056 int *pos, LONGEST *indices, int *num_indices,
10057 int max_indices, LONGEST low, LONGEST high)
10058{
10059 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10060
10061 if (ind - 1 == high)
e1d5a0d2 10062 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
10063 if (ind <= high)
10064 {
10065 add_component_interval (ind, ind, indices, num_indices, max_indices);
10066 *pos += 3;
10067 assign_component (container, lhs, ind, exp, pos);
10068 }
10069 else
10070 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10071}
10072
10073/* Assign into the components of LHS indexed by the OP_CHOICES
10074 construct at *POS, updating *POS past the construct, given that
10075 the allowable indices are LOW..HIGH. Record the indices assigned
10076 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 10077 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10078static void
10079aggregate_assign_from_choices (struct value *container,
10080 struct value *lhs, struct expression *exp,
10081 int *pos, LONGEST *indices, int *num_indices,
10082 int max_indices, LONGEST low, LONGEST high)
10083{
10084 int j;
10085 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10086 int choice_pos, expr_pc;
10087 int is_array = ada_is_direct_array_type (value_type (lhs));
10088
10089 choice_pos = *pos += 3;
10090
10091 for (j = 0; j < n_choices; j += 1)
10092 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10093 expr_pc = *pos;
10094 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10095
10096 for (j = 0; j < n_choices; j += 1)
10097 {
10098 LONGEST lower, upper;
10099 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10100
52ce6436
PH
10101 if (op == OP_DISCRETE_RANGE)
10102 {
10103 choice_pos += 1;
10104 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10105 EVAL_NORMAL));
10106 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10107 EVAL_NORMAL));
10108 }
10109 else if (is_array)
10110 {
10111 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10112 EVAL_NORMAL));
10113 upper = lower;
10114 }
10115 else
10116 {
10117 int ind;
0d5cff50 10118 const char *name;
5b4ee69b 10119
52ce6436
PH
10120 switch (op)
10121 {
10122 case OP_NAME:
10123 name = &exp->elts[choice_pos + 2].string;
10124 break;
10125 case OP_VAR_VALUE:
10126 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10127 break;
10128 default:
10129 error (_("Invalid record component association."));
10130 }
10131 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10132 ind = 0;
10133 if (! find_struct_field (name, value_type (lhs), 0,
10134 NULL, NULL, NULL, NULL, &ind))
10135 error (_("Unknown component name: %s."), name);
10136 lower = upper = ind;
10137 }
10138
10139 if (lower <= upper && (lower < low || upper > high))
10140 error (_("Index in component association out of bounds."));
10141
10142 add_component_interval (lower, upper, indices, num_indices,
10143 max_indices);
10144 while (lower <= upper)
10145 {
10146 int pos1;
5b4ee69b 10147
52ce6436
PH
10148 pos1 = expr_pc;
10149 assign_component (container, lhs, lower, exp, &pos1);
10150 lower += 1;
10151 }
10152 }
10153}
10154
10155/* Assign the value of the expression in the OP_OTHERS construct in
10156 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10157 have not been previously assigned. The index intervals already assigned
10158 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10159 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10160static void
10161aggregate_assign_others (struct value *container,
10162 struct value *lhs, struct expression *exp,
10163 int *pos, LONGEST *indices, int num_indices,
10164 LONGEST low, LONGEST high)
10165{
10166 int i;
5ce64950 10167 int expr_pc = *pos + 1;
52ce6436
PH
10168
10169 for (i = 0; i < num_indices - 2; i += 2)
10170 {
10171 LONGEST ind;
5b4ee69b 10172
52ce6436
PH
10173 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10174 {
5ce64950 10175 int localpos;
5b4ee69b 10176
5ce64950
MS
10177 localpos = expr_pc;
10178 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10179 }
10180 }
10181 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10182}
10183
10184/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10185 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10186 modifying *SIZE as needed. It is an error if *SIZE exceeds
10187 MAX_SIZE. The resulting intervals do not overlap. */
10188static void
10189add_component_interval (LONGEST low, LONGEST high,
10190 LONGEST* indices, int *size, int max_size)
10191{
10192 int i, j;
5b4ee69b 10193
52ce6436
PH
10194 for (i = 0; i < *size; i += 2) {
10195 if (high >= indices[i] && low <= indices[i + 1])
10196 {
10197 int kh;
5b4ee69b 10198
52ce6436
PH
10199 for (kh = i + 2; kh < *size; kh += 2)
10200 if (high < indices[kh])
10201 break;
10202 if (low < indices[i])
10203 indices[i] = low;
10204 indices[i + 1] = indices[kh - 1];
10205 if (high > indices[i + 1])
10206 indices[i + 1] = high;
10207 memcpy (indices + i + 2, indices + kh, *size - kh);
10208 *size -= kh - i - 2;
10209 return;
10210 }
10211 else if (high < indices[i])
10212 break;
10213 }
10214
10215 if (*size == max_size)
10216 error (_("Internal error: miscounted aggregate components."));
10217 *size += 2;
10218 for (j = *size-1; j >= i+2; j -= 1)
10219 indices[j] = indices[j - 2];
10220 indices[i] = low;
10221 indices[i + 1] = high;
10222}
10223
6e48bd2c
JB
10224/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10225 is different. */
10226
10227static struct value *
b7e22850 10228ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10229{
10230 if (type == ada_check_typedef (value_type (arg2)))
10231 return arg2;
10232
10233 if (ada_is_fixed_point_type (type))
95f39a5b 10234 return cast_to_fixed (type, arg2);
6e48bd2c
JB
10235
10236 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10237 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10238
10239 return value_cast (type, arg2);
10240}
10241
284614f0
JB
10242/* Evaluating Ada expressions, and printing their result.
10243 ------------------------------------------------------
10244
21649b50
JB
10245 1. Introduction:
10246 ----------------
10247
284614f0
JB
10248 We usually evaluate an Ada expression in order to print its value.
10249 We also evaluate an expression in order to print its type, which
10250 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10251 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10252 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10253 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10254 similar.
10255
10256 Evaluating expressions is a little more complicated for Ada entities
10257 than it is for entities in languages such as C. The main reason for
10258 this is that Ada provides types whose definition might be dynamic.
10259 One example of such types is variant records. Or another example
10260 would be an array whose bounds can only be known at run time.
10261
10262 The following description is a general guide as to what should be
10263 done (and what should NOT be done) in order to evaluate an expression
10264 involving such types, and when. This does not cover how the semantic
10265 information is encoded by GNAT as this is covered separatly. For the
10266 document used as the reference for the GNAT encoding, see exp_dbug.ads
10267 in the GNAT sources.
10268
10269 Ideally, we should embed each part of this description next to its
10270 associated code. Unfortunately, the amount of code is so vast right
10271 now that it's hard to see whether the code handling a particular
10272 situation might be duplicated or not. One day, when the code is
10273 cleaned up, this guide might become redundant with the comments
10274 inserted in the code, and we might want to remove it.
10275
21649b50
JB
10276 2. ``Fixing'' an Entity, the Simple Case:
10277 -----------------------------------------
10278
284614f0
JB
10279 When evaluating Ada expressions, the tricky issue is that they may
10280 reference entities whose type contents and size are not statically
10281 known. Consider for instance a variant record:
10282
10283 type Rec (Empty : Boolean := True) is record
10284 case Empty is
10285 when True => null;
10286 when False => Value : Integer;
10287 end case;
10288 end record;
10289 Yes : Rec := (Empty => False, Value => 1);
10290 No : Rec := (empty => True);
10291
10292 The size and contents of that record depends on the value of the
10293 descriminant (Rec.Empty). At this point, neither the debugging
10294 information nor the associated type structure in GDB are able to
10295 express such dynamic types. So what the debugger does is to create
10296 "fixed" versions of the type that applies to the specific object.
10297 We also informally refer to this opperation as "fixing" an object,
10298 which means creating its associated fixed type.
10299
10300 Example: when printing the value of variable "Yes" above, its fixed
10301 type would look like this:
10302
10303 type Rec is record
10304 Empty : Boolean;
10305 Value : Integer;
10306 end record;
10307
10308 On the other hand, if we printed the value of "No", its fixed type
10309 would become:
10310
10311 type Rec is record
10312 Empty : Boolean;
10313 end record;
10314
10315 Things become a little more complicated when trying to fix an entity
10316 with a dynamic type that directly contains another dynamic type,
10317 such as an array of variant records, for instance. There are
10318 two possible cases: Arrays, and records.
10319
21649b50
JB
10320 3. ``Fixing'' Arrays:
10321 ---------------------
10322
10323 The type structure in GDB describes an array in terms of its bounds,
10324 and the type of its elements. By design, all elements in the array
10325 have the same type and we cannot represent an array of variant elements
10326 using the current type structure in GDB. When fixing an array,
10327 we cannot fix the array element, as we would potentially need one
10328 fixed type per element of the array. As a result, the best we can do
10329 when fixing an array is to produce an array whose bounds and size
10330 are correct (allowing us to read it from memory), but without having
10331 touched its element type. Fixing each element will be done later,
10332 when (if) necessary.
10333
10334 Arrays are a little simpler to handle than records, because the same
10335 amount of memory is allocated for each element of the array, even if
1b536f04 10336 the amount of space actually used by each element differs from element
21649b50 10337 to element. Consider for instance the following array of type Rec:
284614f0
JB
10338
10339 type Rec_Array is array (1 .. 2) of Rec;
10340
1b536f04
JB
10341 The actual amount of memory occupied by each element might be different
10342 from element to element, depending on the value of their discriminant.
21649b50 10343 But the amount of space reserved for each element in the array remains
1b536f04 10344 fixed regardless. So we simply need to compute that size using
21649b50
JB
10345 the debugging information available, from which we can then determine
10346 the array size (we multiply the number of elements of the array by
10347 the size of each element).
10348
10349 The simplest case is when we have an array of a constrained element
10350 type. For instance, consider the following type declarations:
10351
10352 type Bounded_String (Max_Size : Integer) is
10353 Length : Integer;
10354 Buffer : String (1 .. Max_Size);
10355 end record;
10356 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10357
10358 In this case, the compiler describes the array as an array of
10359 variable-size elements (identified by its XVS suffix) for which
10360 the size can be read in the parallel XVZ variable.
10361
10362 In the case of an array of an unconstrained element type, the compiler
10363 wraps the array element inside a private PAD type. This type should not
10364 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10365 that we also use the adjective "aligner" in our code to designate
10366 these wrapper types.
10367
1b536f04 10368 In some cases, the size allocated for each element is statically
21649b50
JB
10369 known. In that case, the PAD type already has the correct size,
10370 and the array element should remain unfixed.
10371
10372 But there are cases when this size is not statically known.
10373 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10374
10375 type Dynamic is array (1 .. Five) of Integer;
10376 type Wrapper (Has_Length : Boolean := False) is record
10377 Data : Dynamic;
10378 case Has_Length is
10379 when True => Length : Integer;
10380 when False => null;
10381 end case;
10382 end record;
10383 type Wrapper_Array is array (1 .. 2) of Wrapper;
10384
10385 Hello : Wrapper_Array := (others => (Has_Length => True,
10386 Data => (others => 17),
10387 Length => 1));
10388
10389
10390 The debugging info would describe variable Hello as being an
10391 array of a PAD type. The size of that PAD type is not statically
10392 known, but can be determined using a parallel XVZ variable.
10393 In that case, a copy of the PAD type with the correct size should
10394 be used for the fixed array.
10395
21649b50
JB
10396 3. ``Fixing'' record type objects:
10397 ----------------------------------
10398
10399 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10400 record types. In this case, in order to compute the associated
10401 fixed type, we need to determine the size and offset of each of
10402 its components. This, in turn, requires us to compute the fixed
10403 type of each of these components.
10404
10405 Consider for instance the example:
10406
10407 type Bounded_String (Max_Size : Natural) is record
10408 Str : String (1 .. Max_Size);
10409 Length : Natural;
10410 end record;
10411 My_String : Bounded_String (Max_Size => 10);
10412
10413 In that case, the position of field "Length" depends on the size
10414 of field Str, which itself depends on the value of the Max_Size
21649b50 10415 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10416 we need to fix the type of field Str. Therefore, fixing a variant
10417 record requires us to fix each of its components.
10418
10419 However, if a component does not have a dynamic size, the component
10420 should not be fixed. In particular, fields that use a PAD type
10421 should not fixed. Here is an example where this might happen
10422 (assuming type Rec above):
10423
10424 type Container (Big : Boolean) is record
10425 First : Rec;
10426 After : Integer;
10427 case Big is
10428 when True => Another : Integer;
10429 when False => null;
10430 end case;
10431 end record;
10432 My_Container : Container := (Big => False,
10433 First => (Empty => True),
10434 After => 42);
10435
10436 In that example, the compiler creates a PAD type for component First,
10437 whose size is constant, and then positions the component After just
10438 right after it. The offset of component After is therefore constant
10439 in this case.
10440
10441 The debugger computes the position of each field based on an algorithm
10442 that uses, among other things, the actual position and size of the field
21649b50
JB
10443 preceding it. Let's now imagine that the user is trying to print
10444 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10445 end up computing the offset of field After based on the size of the
10446 fixed version of field First. And since in our example First has
10447 only one actual field, the size of the fixed type is actually smaller
10448 than the amount of space allocated to that field, and thus we would
10449 compute the wrong offset of field After.
10450
21649b50
JB
10451 To make things more complicated, we need to watch out for dynamic
10452 components of variant records (identified by the ___XVL suffix in
10453 the component name). Even if the target type is a PAD type, the size
10454 of that type might not be statically known. So the PAD type needs
10455 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10456 we might end up with the wrong size for our component. This can be
10457 observed with the following type declarations:
284614f0
JB
10458
10459 type Octal is new Integer range 0 .. 7;
10460 type Octal_Array is array (Positive range <>) of Octal;
10461 pragma Pack (Octal_Array);
10462
10463 type Octal_Buffer (Size : Positive) is record
10464 Buffer : Octal_Array (1 .. Size);
10465 Length : Integer;
10466 end record;
10467
10468 In that case, Buffer is a PAD type whose size is unset and needs
10469 to be computed by fixing the unwrapped type.
10470
21649b50
JB
10471 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10472 ----------------------------------------------------------
10473
10474 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10475 thus far, be actually fixed?
10476
10477 The answer is: Only when referencing that element. For instance
10478 when selecting one component of a record, this specific component
10479 should be fixed at that point in time. Or when printing the value
10480 of a record, each component should be fixed before its value gets
10481 printed. Similarly for arrays, the element of the array should be
10482 fixed when printing each element of the array, or when extracting
10483 one element out of that array. On the other hand, fixing should
10484 not be performed on the elements when taking a slice of an array!
10485
31432a67 10486 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10487 size of each field is that we end up also miscomputing the size
10488 of the containing type. This can have adverse results when computing
10489 the value of an entity. GDB fetches the value of an entity based
10490 on the size of its type, and thus a wrong size causes GDB to fetch
10491 the wrong amount of memory. In the case where the computed size is
10492 too small, GDB fetches too little data to print the value of our
31432a67 10493 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10494 past the buffer containing the data =:-o. */
10495
ced9779b
JB
10496/* Evaluate a subexpression of EXP, at index *POS, and return a value
10497 for that subexpression cast to TO_TYPE. Advance *POS over the
10498 subexpression. */
10499
10500static value *
10501ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10502 enum noside noside, struct type *to_type)
10503{
10504 int pc = *pos;
10505
10506 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10507 || exp->elts[pc].opcode == OP_VAR_VALUE)
10508 {
10509 (*pos) += 4;
10510
10511 value *val;
10512 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10513 {
10514 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10515 return value_zero (to_type, not_lval);
10516
10517 val = evaluate_var_msym_value (noside,
10518 exp->elts[pc + 1].objfile,
10519 exp->elts[pc + 2].msymbol);
10520 }
10521 else
10522 val = evaluate_var_value (noside,
10523 exp->elts[pc + 1].block,
10524 exp->elts[pc + 2].symbol);
10525
10526 if (noside == EVAL_SKIP)
10527 return eval_skip_value (exp);
10528
10529 val = ada_value_cast (to_type, val);
10530
10531 /* Follow the Ada language semantics that do not allow taking
10532 an address of the result of a cast (view conversion in Ada). */
10533 if (VALUE_LVAL (val) == lval_memory)
10534 {
10535 if (value_lazy (val))
10536 value_fetch_lazy (val);
10537 VALUE_LVAL (val) = not_lval;
10538 }
10539 return val;
10540 }
10541
10542 value *val = evaluate_subexp (to_type, exp, pos, noside);
10543 if (noside == EVAL_SKIP)
10544 return eval_skip_value (exp);
10545 return ada_value_cast (to_type, val);
10546}
10547
284614f0
JB
10548/* Implement the evaluate_exp routine in the exp_descriptor structure
10549 for the Ada language. */
10550
52ce6436 10551static struct value *
ebf56fd3 10552ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10553 int *pos, enum noside noside)
14f9c5c9
AS
10554{
10555 enum exp_opcode op;
b5385fc0 10556 int tem;
14f9c5c9 10557 int pc;
5ec18f2b 10558 int preeval_pos;
14f9c5c9
AS
10559 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10560 struct type *type;
52ce6436 10561 int nargs, oplen;
d2e4a39e 10562 struct value **argvec;
14f9c5c9 10563
d2e4a39e
AS
10564 pc = *pos;
10565 *pos += 1;
14f9c5c9
AS
10566 op = exp->elts[pc].opcode;
10567
d2e4a39e 10568 switch (op)
14f9c5c9
AS
10569 {
10570 default:
10571 *pos -= 1;
6e48bd2c 10572 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10573
10574 if (noside == EVAL_NORMAL)
10575 arg1 = unwrap_value (arg1);
6e48bd2c 10576
edd079d9 10577 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10578 then we need to perform the conversion manually, because
10579 evaluate_subexp_standard doesn't do it. This conversion is
10580 necessary in Ada because the different kinds of float/fixed
10581 types in Ada have different representations.
10582
10583 Similarly, we need to perform the conversion from OP_LONG
10584 ourselves. */
edd079d9 10585 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10586 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10587
10588 return arg1;
4c4b4cd2
PH
10589
10590 case OP_STRING:
10591 {
76a01679 10592 struct value *result;
5b4ee69b 10593
76a01679
JB
10594 *pos -= 1;
10595 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10596 /* The result type will have code OP_STRING, bashed there from
10597 OP_ARRAY. Bash it back. */
df407dfe
AC
10598 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10599 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10600 return result;
4c4b4cd2 10601 }
14f9c5c9
AS
10602
10603 case UNOP_CAST:
10604 (*pos) += 2;
10605 type = exp->elts[pc + 1].type;
ced9779b 10606 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10607
4c4b4cd2
PH
10608 case UNOP_QUAL:
10609 (*pos) += 2;
10610 type = exp->elts[pc + 1].type;
10611 return ada_evaluate_subexp (type, exp, pos, noside);
10612
14f9c5c9
AS
10613 case BINOP_ASSIGN:
10614 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10615 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10616 {
10617 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10618 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10619 return arg1;
10620 return ada_value_assign (arg1, arg1);
10621 }
003f3813
JB
10622 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10623 except if the lhs of our assignment is a convenience variable.
10624 In the case of assigning to a convenience variable, the lhs
10625 should be exactly the result of the evaluation of the rhs. */
10626 type = value_type (arg1);
10627 if (VALUE_LVAL (arg1) == lval_internalvar)
10628 type = NULL;
10629 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10630 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10631 return arg1;
df407dfe
AC
10632 if (ada_is_fixed_point_type (value_type (arg1)))
10633 arg2 = cast_to_fixed (value_type (arg1), arg2);
10634 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10635 error
323e0a4a 10636 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10637 else
df407dfe 10638 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10639 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10640
10641 case BINOP_ADD:
10642 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10643 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10644 if (noside == EVAL_SKIP)
4c4b4cd2 10645 goto nosideret;
2ac8a782
JB
10646 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10647 return (value_from_longest
10648 (value_type (arg1),
10649 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10650 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10651 return (value_from_longest
10652 (value_type (arg2),
10653 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10654 if ((ada_is_fixed_point_type (value_type (arg1))
10655 || ada_is_fixed_point_type (value_type (arg2)))
10656 && value_type (arg1) != value_type (arg2))
323e0a4a 10657 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10658 /* Do the addition, and cast the result to the type of the first
10659 argument. We cannot cast the result to a reference type, so if
10660 ARG1 is a reference type, find its underlying type. */
10661 type = value_type (arg1);
10662 while (TYPE_CODE (type) == TYPE_CODE_REF)
10663 type = TYPE_TARGET_TYPE (type);
f44316fa 10664 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10665 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10666
10667 case BINOP_SUB:
10668 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10669 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10670 if (noside == EVAL_SKIP)
4c4b4cd2 10671 goto nosideret;
2ac8a782
JB
10672 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10673 return (value_from_longest
10674 (value_type (arg1),
10675 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10676 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10677 return (value_from_longest
10678 (value_type (arg2),
10679 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10680 if ((ada_is_fixed_point_type (value_type (arg1))
10681 || ada_is_fixed_point_type (value_type (arg2)))
10682 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10683 error (_("Operands of fixed-point subtraction "
10684 "must have the same type"));
b7789565
JB
10685 /* Do the substraction, and cast the result to the type of the first
10686 argument. We cannot cast the result to a reference type, so if
10687 ARG1 is a reference type, find its underlying type. */
10688 type = value_type (arg1);
10689 while (TYPE_CODE (type) == TYPE_CODE_REF)
10690 type = TYPE_TARGET_TYPE (type);
f44316fa 10691 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10692 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10693
10694 case BINOP_MUL:
10695 case BINOP_DIV:
e1578042
JB
10696 case BINOP_REM:
10697 case BINOP_MOD:
14f9c5c9
AS
10698 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10699 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10700 if (noside == EVAL_SKIP)
4c4b4cd2 10701 goto nosideret;
e1578042 10702 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10703 {
10704 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10705 return value_zero (value_type (arg1), not_lval);
10706 }
14f9c5c9 10707 else
4c4b4cd2 10708 {
a53b7a21 10709 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10710 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10711 arg1 = cast_from_fixed (type, arg1);
df407dfe 10712 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10713 arg2 = cast_from_fixed (type, arg2);
f44316fa 10714 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10715 return ada_value_binop (arg1, arg2, op);
10716 }
10717
4c4b4cd2
PH
10718 case BINOP_EQUAL:
10719 case BINOP_NOTEQUAL:
14f9c5c9 10720 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10721 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10722 if (noside == EVAL_SKIP)
76a01679 10723 goto nosideret;
4c4b4cd2 10724 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10725 tem = 0;
4c4b4cd2 10726 else
f44316fa
UW
10727 {
10728 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10729 tem = ada_value_equal (arg1, arg2);
10730 }
4c4b4cd2 10731 if (op == BINOP_NOTEQUAL)
76a01679 10732 tem = !tem;
fbb06eb1
UW
10733 type = language_bool_type (exp->language_defn, exp->gdbarch);
10734 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10735
10736 case UNOP_NEG:
10737 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10738 if (noside == EVAL_SKIP)
10739 goto nosideret;
df407dfe
AC
10740 else if (ada_is_fixed_point_type (value_type (arg1)))
10741 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10742 else
f44316fa
UW
10743 {
10744 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10745 return value_neg (arg1);
10746 }
4c4b4cd2 10747
2330c6c6
JB
10748 case BINOP_LOGICAL_AND:
10749 case BINOP_LOGICAL_OR:
10750 case UNOP_LOGICAL_NOT:
000d5124
JB
10751 {
10752 struct value *val;
10753
10754 *pos -= 1;
10755 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10756 type = language_bool_type (exp->language_defn, exp->gdbarch);
10757 return value_cast (type, val);
000d5124 10758 }
2330c6c6
JB
10759
10760 case BINOP_BITWISE_AND:
10761 case BINOP_BITWISE_IOR:
10762 case BINOP_BITWISE_XOR:
000d5124
JB
10763 {
10764 struct value *val;
10765
10766 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10767 *pos = pc;
10768 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10769
10770 return value_cast (value_type (arg1), val);
10771 }
2330c6c6 10772
14f9c5c9
AS
10773 case OP_VAR_VALUE:
10774 *pos -= 1;
6799def4 10775
14f9c5c9 10776 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10777 {
10778 *pos += 4;
10779 goto nosideret;
10780 }
da5c522f
JB
10781
10782 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10783 /* Only encountered when an unresolved symbol occurs in a
10784 context other than a function call, in which case, it is
52ce6436 10785 invalid. */
323e0a4a 10786 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10787 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10788
10789 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10790 {
0c1f74cf 10791 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10792 /* Check to see if this is a tagged type. We also need to handle
10793 the case where the type is a reference to a tagged type, but
10794 we have to be careful to exclude pointers to tagged types.
10795 The latter should be shown as usual (as a pointer), whereas
10796 a reference should mostly be transparent to the user. */
10797 if (ada_is_tagged_type (type, 0)
023db19c 10798 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10799 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10800 {
10801 /* Tagged types are a little special in the fact that the real
10802 type is dynamic and can only be determined by inspecting the
10803 object's tag. This means that we need to get the object's
10804 value first (EVAL_NORMAL) and then extract the actual object
10805 type from its tag.
10806
10807 Note that we cannot skip the final step where we extract
10808 the object type from its tag, because the EVAL_NORMAL phase
10809 results in dynamic components being resolved into fixed ones.
10810 This can cause problems when trying to print the type
10811 description of tagged types whose parent has a dynamic size:
10812 We use the type name of the "_parent" component in order
10813 to print the name of the ancestor type in the type description.
10814 If that component had a dynamic size, the resolution into
10815 a fixed type would result in the loss of that type name,
10816 thus preventing us from printing the name of the ancestor
10817 type in the type description. */
10818 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10819
10820 if (TYPE_CODE (type) != TYPE_CODE_REF)
10821 {
10822 struct type *actual_type;
10823
10824 actual_type = type_from_tag (ada_value_tag (arg1));
10825 if (actual_type == NULL)
10826 /* If, for some reason, we were unable to determine
10827 the actual type from the tag, then use the static
10828 approximation that we just computed as a fallback.
10829 This can happen if the debugging information is
10830 incomplete, for instance. */
10831 actual_type = type;
10832 return value_zero (actual_type, not_lval);
10833 }
10834 else
10835 {
10836 /* In the case of a ref, ada_coerce_ref takes care
10837 of determining the actual type. But the evaluation
10838 should return a ref as it should be valid to ask
10839 for its address; so rebuild a ref after coerce. */
10840 arg1 = ada_coerce_ref (arg1);
a65cfae5 10841 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10842 }
10843 }
0c1f74cf 10844
84754697
JB
10845 /* Records and unions for which GNAT encodings have been
10846 generated need to be statically fixed as well.
10847 Otherwise, non-static fixing produces a type where
10848 all dynamic properties are removed, which prevents "ptype"
10849 from being able to completely describe the type.
10850 For instance, a case statement in a variant record would be
10851 replaced by the relevant components based on the actual
10852 value of the discriminants. */
10853 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10854 && dynamic_template_type (type) != NULL)
10855 || (TYPE_CODE (type) == TYPE_CODE_UNION
10856 && ada_find_parallel_type (type, "___XVU") != NULL))
10857 {
10858 *pos += 4;
10859 return value_zero (to_static_fixed_type (type), not_lval);
10860 }
4c4b4cd2 10861 }
da5c522f
JB
10862
10863 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10864 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10865
10866 case OP_FUNCALL:
10867 (*pos) += 2;
10868
10869 /* Allocate arg vector, including space for the function to be
10870 called in argvec[0] and a terminating NULL. */
10871 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10872 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10873
10874 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10875 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10876 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10877 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10878 else
10879 {
10880 for (tem = 0; tem <= nargs; tem += 1)
10881 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10882 argvec[tem] = 0;
10883
10884 if (noside == EVAL_SKIP)
10885 goto nosideret;
10886 }
10887
ad82864c
JB
10888 if (ada_is_constrained_packed_array_type
10889 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10890 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10891 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10892 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10893 /* This is a packed array that has already been fixed, and
10894 therefore already coerced to a simple array. Nothing further
10895 to do. */
10896 ;
e6c2c623
PMR
10897 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10898 {
10899 /* Make sure we dereference references so that all the code below
10900 feels like it's really handling the referenced value. Wrapping
10901 types (for alignment) may be there, so make sure we strip them as
10902 well. */
10903 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10904 }
10905 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10906 && VALUE_LVAL (argvec[0]) == lval_memory)
10907 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10908
df407dfe 10909 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10910
10911 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10912 them. So, if this is an array typedef (encoding use for array
10913 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10914 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10915 type = ada_typedef_target_type (type);
10916
4c4b4cd2
PH
10917 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10918 {
61ee279c 10919 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10920 {
10921 case TYPE_CODE_FUNC:
61ee279c 10922 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10923 break;
10924 case TYPE_CODE_ARRAY:
10925 break;
10926 case TYPE_CODE_STRUCT:
10927 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10928 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10929 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10930 break;
10931 default:
323e0a4a 10932 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10933 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10934 break;
10935 }
10936 }
10937
10938 switch (TYPE_CODE (type))
10939 {
10940 case TYPE_CODE_FUNC:
10941 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10942 {
7022349d
PA
10943 if (TYPE_TARGET_TYPE (type) == NULL)
10944 error_call_unknown_return_type (NULL);
10945 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10946 }
e71585ff
PA
10947 return call_function_by_hand (argvec[0], NULL,
10948 gdb::make_array_view (argvec + 1,
10949 nargs));
c8ea1972
PH
10950 case TYPE_CODE_INTERNAL_FUNCTION:
10951 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10952 /* We don't know anything about what the internal
10953 function might return, but we have to return
10954 something. */
10955 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10956 not_lval);
10957 else
10958 return call_internal_function (exp->gdbarch, exp->language_defn,
10959 argvec[0], nargs, argvec + 1);
10960
4c4b4cd2
PH
10961 case TYPE_CODE_STRUCT:
10962 {
10963 int arity;
10964
4c4b4cd2
PH
10965 arity = ada_array_arity (type);
10966 type = ada_array_element_type (type, nargs);
10967 if (type == NULL)
323e0a4a 10968 error (_("cannot subscript or call a record"));
4c4b4cd2 10969 if (arity != nargs)
323e0a4a 10970 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10971 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10972 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10973 return
10974 unwrap_value (ada_value_subscript
10975 (argvec[0], nargs, argvec + 1));
10976 }
10977 case TYPE_CODE_ARRAY:
10978 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10979 {
10980 type = ada_array_element_type (type, nargs);
10981 if (type == NULL)
323e0a4a 10982 error (_("element type of array unknown"));
4c4b4cd2 10983 else
0a07e705 10984 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10985 }
10986 return
10987 unwrap_value (ada_value_subscript
10988 (ada_coerce_to_simple_array (argvec[0]),
10989 nargs, argvec + 1));
10990 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10991 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10992 {
deede10c 10993 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10994 type = ada_array_element_type (type, nargs);
10995 if (type == NULL)
323e0a4a 10996 error (_("element type of array unknown"));
4c4b4cd2 10997 else
0a07e705 10998 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10999 }
11000 return
deede10c
JB
11001 unwrap_value (ada_value_ptr_subscript (argvec[0],
11002 nargs, argvec + 1));
4c4b4cd2
PH
11003
11004 default:
e1d5a0d2
PH
11005 error (_("Attempt to index or call something other than an "
11006 "array or function"));
4c4b4cd2
PH
11007 }
11008
11009 case TERNOP_SLICE:
11010 {
11011 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11012 struct value *low_bound_val =
11013 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
11014 struct value *high_bound_val =
11015 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11016 LONGEST low_bound;
11017 LONGEST high_bound;
5b4ee69b 11018
994b9211
AC
11019 low_bound_val = coerce_ref (low_bound_val);
11020 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
11021 low_bound = value_as_long (low_bound_val);
11022 high_bound = value_as_long (high_bound_val);
963a6417 11023
4c4b4cd2
PH
11024 if (noside == EVAL_SKIP)
11025 goto nosideret;
11026
4c4b4cd2
PH
11027 /* If this is a reference to an aligner type, then remove all
11028 the aligners. */
df407dfe
AC
11029 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11030 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11031 TYPE_TARGET_TYPE (value_type (array)) =
11032 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 11033
ad82864c 11034 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 11035 error (_("cannot slice a packed array"));
4c4b4cd2
PH
11036
11037 /* If this is a reference to an array or an array lvalue,
11038 convert to a pointer. */
df407dfe
AC
11039 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11040 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
11041 && VALUE_LVAL (array) == lval_memory))
11042 array = value_addr (array);
11043
1265e4aa 11044 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 11045 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 11046 (value_type (array))))
bff8c71f
TT
11047 return empty_array (ada_type_of_array (array, 0), low_bound,
11048 high_bound);
4c4b4cd2
PH
11049
11050 array = ada_coerce_to_simple_array_ptr (array);
11051
714e53ab
PH
11052 /* If we have more than one level of pointer indirection,
11053 dereference the value until we get only one level. */
df407dfe
AC
11054 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11055 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
11056 == TYPE_CODE_PTR))
11057 array = value_ind (array);
11058
11059 /* Make sure we really do have an array type before going further,
11060 to avoid a SEGV when trying to get the index type or the target
11061 type later down the road if the debug info generated by
11062 the compiler is incorrect or incomplete. */
df407dfe 11063 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 11064 error (_("cannot take slice of non-array"));
714e53ab 11065
828292f2
JB
11066 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11067 == TYPE_CODE_PTR)
4c4b4cd2 11068 {
828292f2
JB
11069 struct type *type0 = ada_check_typedef (value_type (array));
11070
0b5d8877 11071 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
bff8c71f 11072 return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
4c4b4cd2
PH
11073 else
11074 {
11075 struct type *arr_type0 =
828292f2 11076 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 11077
f5938064
JG
11078 return ada_value_slice_from_ptr (array, arr_type0,
11079 longest_to_int (low_bound),
11080 longest_to_int (high_bound));
4c4b4cd2
PH
11081 }
11082 }
11083 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11084 return array;
11085 else if (high_bound < low_bound)
bff8c71f 11086 return empty_array (value_type (array), low_bound, high_bound);
4c4b4cd2 11087 else
529cad9c
PH
11088 return ada_value_slice (array, longest_to_int (low_bound),
11089 longest_to_int (high_bound));
4c4b4cd2 11090 }
14f9c5c9 11091
4c4b4cd2
PH
11092 case UNOP_IN_RANGE:
11093 (*pos) += 2;
11094 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 11095 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 11096
14f9c5c9 11097 if (noside == EVAL_SKIP)
4c4b4cd2 11098 goto nosideret;
14f9c5c9 11099
4c4b4cd2
PH
11100 switch (TYPE_CODE (type))
11101 {
11102 default:
e1d5a0d2
PH
11103 lim_warning (_("Membership test incompletely implemented; "
11104 "always returns true"));
fbb06eb1
UW
11105 type = language_bool_type (exp->language_defn, exp->gdbarch);
11106 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
11107
11108 case TYPE_CODE_RANGE:
030b4912
UW
11109 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11110 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
11111 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11112 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
11113 type = language_bool_type (exp->language_defn, exp->gdbarch);
11114 return
11115 value_from_longest (type,
4c4b4cd2
PH
11116 (value_less (arg1, arg3)
11117 || value_equal (arg1, arg3))
11118 && (value_less (arg2, arg1)
11119 || value_equal (arg2, arg1)));
11120 }
11121
11122 case BINOP_IN_BOUNDS:
14f9c5c9 11123 (*pos) += 2;
4c4b4cd2
PH
11124 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11125 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11126
4c4b4cd2
PH
11127 if (noside == EVAL_SKIP)
11128 goto nosideret;
14f9c5c9 11129
4c4b4cd2 11130 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
11131 {
11132 type = language_bool_type (exp->language_defn, exp->gdbarch);
11133 return value_zero (type, not_lval);
11134 }
14f9c5c9 11135
4c4b4cd2 11136 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11137
1eea4ebd
UW
11138 type = ada_index_type (value_type (arg2), tem, "range");
11139 if (!type)
11140 type = value_type (arg1);
14f9c5c9 11141
1eea4ebd
UW
11142 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11143 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11144
f44316fa
UW
11145 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11146 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11147 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11148 return
fbb06eb1 11149 value_from_longest (type,
4c4b4cd2
PH
11150 (value_less (arg1, arg3)
11151 || value_equal (arg1, arg3))
11152 && (value_less (arg2, arg1)
11153 || value_equal (arg2, arg1)));
11154
11155 case TERNOP_IN_RANGE:
11156 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11157 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11158 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11159
11160 if (noside == EVAL_SKIP)
11161 goto nosideret;
11162
f44316fa
UW
11163 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11164 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11165 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11166 return
fbb06eb1 11167 value_from_longest (type,
4c4b4cd2
PH
11168 (value_less (arg1, arg3)
11169 || value_equal (arg1, arg3))
11170 && (value_less (arg2, arg1)
11171 || value_equal (arg2, arg1)));
11172
11173 case OP_ATR_FIRST:
11174 case OP_ATR_LAST:
11175 case OP_ATR_LENGTH:
11176 {
76a01679 11177 struct type *type_arg;
5b4ee69b 11178
76a01679
JB
11179 if (exp->elts[*pos].opcode == OP_TYPE)
11180 {
11181 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11182 arg1 = NULL;
5bc23cb3 11183 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11184 }
11185 else
11186 {
11187 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11188 type_arg = NULL;
11189 }
11190
11191 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11192 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11193 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11194 *pos += 4;
11195
11196 if (noside == EVAL_SKIP)
11197 goto nosideret;
11198
11199 if (type_arg == NULL)
11200 {
11201 arg1 = ada_coerce_ref (arg1);
11202
ad82864c 11203 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11204 arg1 = ada_coerce_to_simple_array (arg1);
11205
aa4fb036 11206 if (op == OP_ATR_LENGTH)
1eea4ebd 11207 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11208 else
11209 {
11210 type = ada_index_type (value_type (arg1), tem,
11211 ada_attribute_name (op));
11212 if (type == NULL)
11213 type = builtin_type (exp->gdbarch)->builtin_int;
11214 }
76a01679
JB
11215
11216 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11217 return allocate_value (type);
76a01679
JB
11218
11219 switch (op)
11220 {
11221 default: /* Should never happen. */
323e0a4a 11222 error (_("unexpected attribute encountered"));
76a01679 11223 case OP_ATR_FIRST:
1eea4ebd
UW
11224 return value_from_longest
11225 (type, ada_array_bound (arg1, tem, 0));
76a01679 11226 case OP_ATR_LAST:
1eea4ebd
UW
11227 return value_from_longest
11228 (type, ada_array_bound (arg1, tem, 1));
76a01679 11229 case OP_ATR_LENGTH:
1eea4ebd
UW
11230 return value_from_longest
11231 (type, ada_array_length (arg1, tem));
76a01679
JB
11232 }
11233 }
11234 else if (discrete_type_p (type_arg))
11235 {
11236 struct type *range_type;
0d5cff50 11237 const char *name = ada_type_name (type_arg);
5b4ee69b 11238
76a01679
JB
11239 range_type = NULL;
11240 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11241 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11242 if (range_type == NULL)
11243 range_type = type_arg;
11244 switch (op)
11245 {
11246 default:
323e0a4a 11247 error (_("unexpected attribute encountered"));
76a01679 11248 case OP_ATR_FIRST:
690cc4eb 11249 return value_from_longest
43bbcdc2 11250 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11251 case OP_ATR_LAST:
690cc4eb 11252 return value_from_longest
43bbcdc2 11253 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11254 case OP_ATR_LENGTH:
323e0a4a 11255 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11256 }
11257 }
11258 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11259 error (_("unimplemented type attribute"));
76a01679
JB
11260 else
11261 {
11262 LONGEST low, high;
11263
ad82864c
JB
11264 if (ada_is_constrained_packed_array_type (type_arg))
11265 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11266
aa4fb036 11267 if (op == OP_ATR_LENGTH)
1eea4ebd 11268 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11269 else
11270 {
11271 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11272 if (type == NULL)
11273 type = builtin_type (exp->gdbarch)->builtin_int;
11274 }
1eea4ebd 11275
76a01679
JB
11276 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11277 return allocate_value (type);
11278
11279 switch (op)
11280 {
11281 default:
323e0a4a 11282 error (_("unexpected attribute encountered"));
76a01679 11283 case OP_ATR_FIRST:
1eea4ebd 11284 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11285 return value_from_longest (type, low);
11286 case OP_ATR_LAST:
1eea4ebd 11287 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11288 return value_from_longest (type, high);
11289 case OP_ATR_LENGTH:
1eea4ebd
UW
11290 low = ada_array_bound_from_type (type_arg, tem, 0);
11291 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11292 return value_from_longest (type, high - low + 1);
11293 }
11294 }
14f9c5c9
AS
11295 }
11296
4c4b4cd2
PH
11297 case OP_ATR_TAG:
11298 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11299 if (noside == EVAL_SKIP)
76a01679 11300 goto nosideret;
4c4b4cd2
PH
11301
11302 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11303 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11304
11305 return ada_value_tag (arg1);
11306
11307 case OP_ATR_MIN:
11308 case OP_ATR_MAX:
11309 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11310 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11311 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11312 if (noside == EVAL_SKIP)
76a01679 11313 goto nosideret;
d2e4a39e 11314 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11315 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11316 else
f44316fa
UW
11317 {
11318 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11319 return value_binop (arg1, arg2,
11320 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11321 }
14f9c5c9 11322
4c4b4cd2
PH
11323 case OP_ATR_MODULUS:
11324 {
31dedfee 11325 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11326
5b4ee69b 11327 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11328 if (noside == EVAL_SKIP)
11329 goto nosideret;
4c4b4cd2 11330
76a01679 11331 if (!ada_is_modular_type (type_arg))
323e0a4a 11332 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11333
76a01679
JB
11334 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11335 ada_modulus (type_arg));
4c4b4cd2
PH
11336 }
11337
11338
11339 case OP_ATR_POS:
11340 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11341 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11342 if (noside == EVAL_SKIP)
76a01679 11343 goto nosideret;
3cb382c9
UW
11344 type = builtin_type (exp->gdbarch)->builtin_int;
11345 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11346 return value_zero (type, not_lval);
14f9c5c9 11347 else
3cb382c9 11348 return value_pos_atr (type, arg1);
14f9c5c9 11349
4c4b4cd2
PH
11350 case OP_ATR_SIZE:
11351 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11352 type = value_type (arg1);
11353
11354 /* If the argument is a reference, then dereference its type, since
11355 the user is really asking for the size of the actual object,
11356 not the size of the pointer. */
11357 if (TYPE_CODE (type) == TYPE_CODE_REF)
11358 type = TYPE_TARGET_TYPE (type);
11359
4c4b4cd2 11360 if (noside == EVAL_SKIP)
76a01679 11361 goto nosideret;
4c4b4cd2 11362 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11363 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11364 else
22601c15 11365 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11366 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11367
11368 case OP_ATR_VAL:
11369 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11370 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11371 type = exp->elts[pc + 2].type;
14f9c5c9 11372 if (noside == EVAL_SKIP)
76a01679 11373 goto nosideret;
4c4b4cd2 11374 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11375 return value_zero (type, not_lval);
4c4b4cd2 11376 else
76a01679 11377 return value_val_atr (type, arg1);
4c4b4cd2
PH
11378
11379 case BINOP_EXP:
11380 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11381 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11382 if (noside == EVAL_SKIP)
11383 goto nosideret;
11384 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11385 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11386 else
f44316fa
UW
11387 {
11388 /* For integer exponentiation operations,
11389 only promote the first argument. */
11390 if (is_integral_type (value_type (arg2)))
11391 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11392 else
11393 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11394
11395 return value_binop (arg1, arg2, op);
11396 }
4c4b4cd2
PH
11397
11398 case UNOP_PLUS:
11399 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11400 if (noside == EVAL_SKIP)
11401 goto nosideret;
11402 else
11403 return arg1;
11404
11405 case UNOP_ABS:
11406 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11407 if (noside == EVAL_SKIP)
11408 goto nosideret;
f44316fa 11409 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11410 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11411 return value_neg (arg1);
14f9c5c9 11412 else
4c4b4cd2 11413 return arg1;
14f9c5c9
AS
11414
11415 case UNOP_IND:
5ec18f2b 11416 preeval_pos = *pos;
6b0d7253 11417 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11418 if (noside == EVAL_SKIP)
4c4b4cd2 11419 goto nosideret;
df407dfe 11420 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11421 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11422 {
11423 if (ada_is_array_descriptor_type (type))
11424 /* GDB allows dereferencing GNAT array descriptors. */
11425 {
11426 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11427
4c4b4cd2 11428 if (arrType == NULL)
323e0a4a 11429 error (_("Attempt to dereference null array pointer."));
00a4c844 11430 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11431 }
11432 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11433 || TYPE_CODE (type) == TYPE_CODE_REF
11434 /* In C you can dereference an array to get the 1st elt. */
11435 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11436 {
5ec18f2b
JG
11437 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11438 only be determined by inspecting the object's tag.
11439 This means that we need to evaluate completely the
11440 expression in order to get its type. */
11441
023db19c
JB
11442 if ((TYPE_CODE (type) == TYPE_CODE_REF
11443 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11444 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11445 {
11446 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11447 EVAL_NORMAL);
11448 type = value_type (ada_value_ind (arg1));
11449 }
11450 else
11451 {
11452 type = to_static_fixed_type
11453 (ada_aligned_type
11454 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11455 }
c1b5a1a6 11456 ada_ensure_varsize_limit (type);
714e53ab
PH
11457 return value_zero (type, lval_memory);
11458 }
4c4b4cd2 11459 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11460 {
11461 /* GDB allows dereferencing an int. */
11462 if (expect_type == NULL)
11463 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11464 lval_memory);
11465 else
11466 {
11467 expect_type =
11468 to_static_fixed_type (ada_aligned_type (expect_type));
11469 return value_zero (expect_type, lval_memory);
11470 }
11471 }
4c4b4cd2 11472 else
323e0a4a 11473 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11474 }
0963b4bd 11475 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11476 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11477
96967637
JB
11478 if (TYPE_CODE (type) == TYPE_CODE_INT)
11479 /* GDB allows dereferencing an int. If we were given
11480 the expect_type, then use that as the target type.
11481 Otherwise, assume that the target type is an int. */
11482 {
11483 if (expect_type != NULL)
11484 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11485 arg1));
11486 else
11487 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11488 (CORE_ADDR) value_as_address (arg1));
11489 }
6b0d7253 11490
4c4b4cd2
PH
11491 if (ada_is_array_descriptor_type (type))
11492 /* GDB allows dereferencing GNAT array descriptors. */
11493 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11494 else
4c4b4cd2 11495 return ada_value_ind (arg1);
14f9c5c9
AS
11496
11497 case STRUCTOP_STRUCT:
11498 tem = longest_to_int (exp->elts[pc + 1].longconst);
11499 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11500 preeval_pos = *pos;
14f9c5c9
AS
11501 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11502 if (noside == EVAL_SKIP)
4c4b4cd2 11503 goto nosideret;
14f9c5c9 11504 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11505 {
df407dfe 11506 struct type *type1 = value_type (arg1);
5b4ee69b 11507
76a01679
JB
11508 if (ada_is_tagged_type (type1, 1))
11509 {
11510 type = ada_lookup_struct_elt_type (type1,
11511 &exp->elts[pc + 2].string,
988f6b3d 11512 1, 1);
5ec18f2b
JG
11513
11514 /* If the field is not found, check if it exists in the
11515 extension of this object's type. This means that we
11516 need to evaluate completely the expression. */
11517
76a01679 11518 if (type == NULL)
5ec18f2b
JG
11519 {
11520 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11521 EVAL_NORMAL);
11522 arg1 = ada_value_struct_elt (arg1,
11523 &exp->elts[pc + 2].string,
11524 0);
11525 arg1 = unwrap_value (arg1);
11526 type = value_type (ada_to_fixed_value (arg1));
11527 }
76a01679
JB
11528 }
11529 else
11530 type =
11531 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11532 0);
76a01679
JB
11533
11534 return value_zero (ada_aligned_type (type), lval_memory);
11535 }
14f9c5c9 11536 else
a579cd9a
MW
11537 {
11538 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11539 arg1 = unwrap_value (arg1);
11540 return ada_to_fixed_value (arg1);
11541 }
284614f0 11542
14f9c5c9 11543 case OP_TYPE:
4c4b4cd2
PH
11544 /* The value is not supposed to be used. This is here to make it
11545 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11546 (*pos) += 2;
11547 if (noside == EVAL_SKIP)
4c4b4cd2 11548 goto nosideret;
14f9c5c9 11549 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11550 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11551 else
323e0a4a 11552 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11553
11554 case OP_AGGREGATE:
11555 case OP_CHOICES:
11556 case OP_OTHERS:
11557 case OP_DISCRETE_RANGE:
11558 case OP_POSITIONAL:
11559 case OP_NAME:
11560 if (noside == EVAL_NORMAL)
11561 switch (op)
11562 {
11563 case OP_NAME:
11564 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11565 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11566 case OP_AGGREGATE:
11567 error (_("Aggregates only allowed on the right of an assignment"));
11568 default:
0963b4bd
MS
11569 internal_error (__FILE__, __LINE__,
11570 _("aggregate apparently mangled"));
52ce6436
PH
11571 }
11572
11573 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11574 *pos += oplen - 1;
11575 for (tem = 0; tem < nargs; tem += 1)
11576 ada_evaluate_subexp (NULL, exp, pos, noside);
11577 goto nosideret;
14f9c5c9
AS
11578 }
11579
11580nosideret:
ced9779b 11581 return eval_skip_value (exp);
14f9c5c9 11582}
14f9c5c9 11583\f
d2e4a39e 11584
4c4b4cd2 11585 /* Fixed point */
14f9c5c9
AS
11586
11587/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11588 type name that encodes the 'small and 'delta information.
4c4b4cd2 11589 Otherwise, return NULL. */
14f9c5c9 11590
d2e4a39e 11591static const char *
ebf56fd3 11592fixed_type_info (struct type *type)
14f9c5c9 11593{
d2e4a39e 11594 const char *name = ada_type_name (type);
14f9c5c9
AS
11595 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11596
d2e4a39e
AS
11597 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11598 {
14f9c5c9 11599 const char *tail = strstr (name, "___XF_");
5b4ee69b 11600
14f9c5c9 11601 if (tail == NULL)
4c4b4cd2 11602 return NULL;
d2e4a39e 11603 else
4c4b4cd2 11604 return tail + 5;
14f9c5c9
AS
11605 }
11606 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11607 return fixed_type_info (TYPE_TARGET_TYPE (type));
11608 else
11609 return NULL;
11610}
11611
4c4b4cd2 11612/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11613
11614int
ebf56fd3 11615ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11616{
11617 return fixed_type_info (type) != NULL;
11618}
11619
4c4b4cd2
PH
11620/* Return non-zero iff TYPE represents a System.Address type. */
11621
11622int
11623ada_is_system_address_type (struct type *type)
11624{
11625 return (TYPE_NAME (type)
11626 && strcmp (TYPE_NAME (type), "system__address") == 0);
11627}
11628
14f9c5c9 11629/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11630 type, return the target floating-point type to be used to represent
11631 of this type during internal computation. */
11632
11633static struct type *
11634ada_scaling_type (struct type *type)
11635{
11636 return builtin_type (get_type_arch (type))->builtin_long_double;
11637}
11638
11639/* Assuming that TYPE is the representation of an Ada fixed-point
11640 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11641 delta cannot be determined. */
14f9c5c9 11642
50eff16b 11643struct value *
ebf56fd3 11644ada_delta (struct type *type)
14f9c5c9
AS
11645{
11646 const char *encoding = fixed_type_info (type);
50eff16b
UW
11647 struct type *scale_type = ada_scaling_type (type);
11648
11649 long long num, den;
11650
11651 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11652 return nullptr;
d2e4a39e 11653 else
50eff16b
UW
11654 return value_binop (value_from_longest (scale_type, num),
11655 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11656}
11657
11658/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11659 factor ('SMALL value) associated with the type. */
14f9c5c9 11660
50eff16b
UW
11661struct value *
11662ada_scaling_factor (struct type *type)
14f9c5c9
AS
11663{
11664 const char *encoding = fixed_type_info (type);
50eff16b
UW
11665 struct type *scale_type = ada_scaling_type (type);
11666
11667 long long num0, den0, num1, den1;
14f9c5c9 11668 int n;
d2e4a39e 11669
50eff16b 11670 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11671 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11672
11673 if (n < 2)
50eff16b 11674 return value_from_longest (scale_type, 1);
14f9c5c9 11675 else if (n == 4)
50eff16b
UW
11676 return value_binop (value_from_longest (scale_type, num1),
11677 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11678 else
50eff16b
UW
11679 return value_binop (value_from_longest (scale_type, num0),
11680 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11681}
11682
14f9c5c9 11683\f
d2e4a39e 11684
4c4b4cd2 11685 /* Range types */
14f9c5c9
AS
11686
11687/* Scan STR beginning at position K for a discriminant name, and
11688 return the value of that discriminant field of DVAL in *PX. If
11689 PNEW_K is not null, put the position of the character beyond the
11690 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11691 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11692
11693static int
108d56a4 11694scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11695 int *pnew_k)
14f9c5c9
AS
11696{
11697 static char *bound_buffer = NULL;
11698 static size_t bound_buffer_len = 0;
5da1a4d3 11699 const char *pstart, *pend, *bound;
d2e4a39e 11700 struct value *bound_val;
14f9c5c9
AS
11701
11702 if (dval == NULL || str == NULL || str[k] == '\0')
11703 return 0;
11704
5da1a4d3
SM
11705 pstart = str + k;
11706 pend = strstr (pstart, "__");
14f9c5c9
AS
11707 if (pend == NULL)
11708 {
5da1a4d3 11709 bound = pstart;
14f9c5c9
AS
11710 k += strlen (bound);
11711 }
d2e4a39e 11712 else
14f9c5c9 11713 {
5da1a4d3
SM
11714 int len = pend - pstart;
11715
11716 /* Strip __ and beyond. */
11717 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11718 strncpy (bound_buffer, pstart, len);
11719 bound_buffer[len] = '\0';
11720
14f9c5c9 11721 bound = bound_buffer;
d2e4a39e 11722 k = pend - str;
14f9c5c9 11723 }
d2e4a39e 11724
df407dfe 11725 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11726 if (bound_val == NULL)
11727 return 0;
11728
11729 *px = value_as_long (bound_val);
11730 if (pnew_k != NULL)
11731 *pnew_k = k;
11732 return 1;
11733}
11734
11735/* Value of variable named NAME in the current environment. If
11736 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11737 otherwise causes an error with message ERR_MSG. */
11738
d2e4a39e 11739static struct value *
edb0c9cb 11740get_var_value (const char *name, const char *err_msg)
14f9c5c9 11741{
b5ec771e 11742 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11743
54d343a2 11744 std::vector<struct block_symbol> syms;
b5ec771e
PA
11745 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11746 get_selected_block (0),
11747 VAR_DOMAIN, &syms, 1);
14f9c5c9
AS
11748
11749 if (nsyms != 1)
11750 {
11751 if (err_msg == NULL)
4c4b4cd2 11752 return 0;
14f9c5c9 11753 else
8a3fe4f8 11754 error (("%s"), err_msg);
14f9c5c9
AS
11755 }
11756
54d343a2 11757 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11758}
d2e4a39e 11759
edb0c9cb
PA
11760/* Value of integer variable named NAME in the current environment.
11761 If no such variable is found, returns false. Otherwise, sets VALUE
11762 to the variable's value and returns true. */
4c4b4cd2 11763
edb0c9cb
PA
11764bool
11765get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11766{
4c4b4cd2 11767 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11768
14f9c5c9 11769 if (var_val == 0)
edb0c9cb
PA
11770 return false;
11771
11772 value = value_as_long (var_val);
11773 return true;
14f9c5c9 11774}
d2e4a39e 11775
14f9c5c9
AS
11776
11777/* Return a range type whose base type is that of the range type named
11778 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11779 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11780 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11781 corresponding range type from debug information; fall back to using it
11782 if symbol lookup fails. If a new type must be created, allocate it
11783 like ORIG_TYPE was. The bounds information, in general, is encoded
11784 in NAME, the base type given in the named range type. */
14f9c5c9 11785
d2e4a39e 11786static struct type *
28c85d6c 11787to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11788{
0d5cff50 11789 const char *name;
14f9c5c9 11790 struct type *base_type;
108d56a4 11791 const char *subtype_info;
14f9c5c9 11792
28c85d6c
JB
11793 gdb_assert (raw_type != NULL);
11794 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11795
1ce677a4 11796 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11797 base_type = TYPE_TARGET_TYPE (raw_type);
11798 else
11799 base_type = raw_type;
11800
28c85d6c 11801 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11802 subtype_info = strstr (name, "___XD");
11803 if (subtype_info == NULL)
690cc4eb 11804 {
43bbcdc2
PH
11805 LONGEST L = ada_discrete_type_low_bound (raw_type);
11806 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11807
690cc4eb
PH
11808 if (L < INT_MIN || U > INT_MAX)
11809 return raw_type;
11810 else
0c9c3474
SA
11811 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11812 L, U);
690cc4eb 11813 }
14f9c5c9
AS
11814 else
11815 {
11816 static char *name_buf = NULL;
11817 static size_t name_len = 0;
11818 int prefix_len = subtype_info - name;
11819 LONGEST L, U;
11820 struct type *type;
108d56a4 11821 const char *bounds_str;
14f9c5c9
AS
11822 int n;
11823
11824 GROW_VECT (name_buf, name_len, prefix_len + 5);
11825 strncpy (name_buf, name, prefix_len);
11826 name_buf[prefix_len] = '\0';
11827
11828 subtype_info += 5;
11829 bounds_str = strchr (subtype_info, '_');
11830 n = 1;
11831
d2e4a39e 11832 if (*subtype_info == 'L')
4c4b4cd2
PH
11833 {
11834 if (!ada_scan_number (bounds_str, n, &L, &n)
11835 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11836 return raw_type;
11837 if (bounds_str[n] == '_')
11838 n += 2;
0963b4bd 11839 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11840 n += 1;
11841 subtype_info += 1;
11842 }
d2e4a39e 11843 else
4c4b4cd2 11844 {
4c4b4cd2 11845 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11846 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11847 {
323e0a4a 11848 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11849 L = 1;
11850 }
11851 }
14f9c5c9 11852
d2e4a39e 11853 if (*subtype_info == 'U')
4c4b4cd2
PH
11854 {
11855 if (!ada_scan_number (bounds_str, n, &U, &n)
11856 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11857 return raw_type;
11858 }
d2e4a39e 11859 else
4c4b4cd2 11860 {
4c4b4cd2 11861 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11862 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11863 {
323e0a4a 11864 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11865 U = L;
11866 }
11867 }
14f9c5c9 11868
0c9c3474
SA
11869 type = create_static_range_type (alloc_type_copy (raw_type),
11870 base_type, L, U);
f5a91472
JB
11871 /* create_static_range_type alters the resulting type's length
11872 to match the size of the base_type, which is not what we want.
11873 Set it back to the original range type's length. */
11874 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11875 TYPE_NAME (type) = name;
14f9c5c9
AS
11876 return type;
11877 }
11878}
11879
4c4b4cd2
PH
11880/* True iff NAME is the name of a range type. */
11881
14f9c5c9 11882int
d2e4a39e 11883ada_is_range_type_name (const char *name)
14f9c5c9
AS
11884{
11885 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11886}
14f9c5c9 11887\f
d2e4a39e 11888
4c4b4cd2
PH
11889 /* Modular types */
11890
11891/* True iff TYPE is an Ada modular type. */
14f9c5c9 11892
14f9c5c9 11893int
d2e4a39e 11894ada_is_modular_type (struct type *type)
14f9c5c9 11895{
18af8284 11896 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11897
11898 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11899 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11900 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11901}
11902
4c4b4cd2
PH
11903/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11904
61ee279c 11905ULONGEST
0056e4d5 11906ada_modulus (struct type *type)
14f9c5c9 11907{
43bbcdc2 11908 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11909}
d2e4a39e 11910\f
f7f9143b
JB
11911
11912/* Ada exception catchpoint support:
11913 ---------------------------------
11914
11915 We support 3 kinds of exception catchpoints:
11916 . catchpoints on Ada exceptions
11917 . catchpoints on unhandled Ada exceptions
11918 . catchpoints on failed assertions
11919
11920 Exceptions raised during failed assertions, or unhandled exceptions
11921 could perfectly be caught with the general catchpoint on Ada exceptions.
11922 However, we can easily differentiate these two special cases, and having
11923 the option to distinguish these two cases from the rest can be useful
11924 to zero-in on certain situations.
11925
11926 Exception catchpoints are a specialized form of breakpoint,
11927 since they rely on inserting breakpoints inside known routines
11928 of the GNAT runtime. The implementation therefore uses a standard
11929 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11930 of breakpoint_ops.
11931
0259addd
JB
11932 Support in the runtime for exception catchpoints have been changed
11933 a few times already, and these changes affect the implementation
11934 of these catchpoints. In order to be able to support several
11935 variants of the runtime, we use a sniffer that will determine
28010a5d 11936 the runtime variant used by the program being debugged. */
f7f9143b 11937
82eacd52
JB
11938/* Ada's standard exceptions.
11939
11940 The Ada 83 standard also defined Numeric_Error. But there so many
11941 situations where it was unclear from the Ada 83 Reference Manual
11942 (RM) whether Constraint_Error or Numeric_Error should be raised,
11943 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11944 Interpretation saying that anytime the RM says that Numeric_Error
11945 should be raised, the implementation may raise Constraint_Error.
11946 Ada 95 went one step further and pretty much removed Numeric_Error
11947 from the list of standard exceptions (it made it a renaming of
11948 Constraint_Error, to help preserve compatibility when compiling
11949 an Ada83 compiler). As such, we do not include Numeric_Error from
11950 this list of standard exceptions. */
3d0b0fa3 11951
a121b7c1 11952static const char *standard_exc[] = {
3d0b0fa3
JB
11953 "constraint_error",
11954 "program_error",
11955 "storage_error",
11956 "tasking_error"
11957};
11958
0259addd
JB
11959typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11960
11961/* A structure that describes how to support exception catchpoints
11962 for a given executable. */
11963
11964struct exception_support_info
11965{
11966 /* The name of the symbol to break on in order to insert
11967 a catchpoint on exceptions. */
11968 const char *catch_exception_sym;
11969
11970 /* The name of the symbol to break on in order to insert
11971 a catchpoint on unhandled exceptions. */
11972 const char *catch_exception_unhandled_sym;
11973
11974 /* The name of the symbol to break on in order to insert
11975 a catchpoint on failed assertions. */
11976 const char *catch_assert_sym;
11977
9f757bf7
XR
11978 /* The name of the symbol to break on in order to insert
11979 a catchpoint on exception handling. */
11980 const char *catch_handlers_sym;
11981
0259addd
JB
11982 /* Assuming that the inferior just triggered an unhandled exception
11983 catchpoint, this function is responsible for returning the address
11984 in inferior memory where the name of that exception is stored.
11985 Return zero if the address could not be computed. */
11986 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11987};
11988
11989static CORE_ADDR ada_unhandled_exception_name_addr (void);
11990static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11991
11992/* The following exception support info structure describes how to
11993 implement exception catchpoints with the latest version of the
11994 Ada runtime (as of 2007-03-06). */
11995
11996static const struct exception_support_info default_exception_support_info =
11997{
11998 "__gnat_debug_raise_exception", /* catch_exception_sym */
11999 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12000 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 12001 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12002 ada_unhandled_exception_name_addr
12003};
12004
12005/* The following exception support info structure describes how to
12006 implement exception catchpoints with a slightly older version
12007 of the Ada runtime. */
12008
12009static const struct exception_support_info exception_support_info_fallback =
12010{
12011 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12012 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12013 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 12014 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12015 ada_unhandled_exception_name_addr_from_raise
12016};
12017
f17011e0
JB
12018/* Return nonzero if we can detect the exception support routines
12019 described in EINFO.
12020
12021 This function errors out if an abnormal situation is detected
12022 (for instance, if we find the exception support routines, but
12023 that support is found to be incomplete). */
12024
12025static int
12026ada_has_this_exception_support (const struct exception_support_info *einfo)
12027{
12028 struct symbol *sym;
12029
12030 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12031 that should be compiled with debugging information. As a result, we
12032 expect to find that symbol in the symtabs. */
12033
12034 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12035 if (sym == NULL)
a6af7abe
JB
12036 {
12037 /* Perhaps we did not find our symbol because the Ada runtime was
12038 compiled without debugging info, or simply stripped of it.
12039 It happens on some GNU/Linux distributions for instance, where
12040 users have to install a separate debug package in order to get
12041 the runtime's debugging info. In that situation, let the user
12042 know why we cannot insert an Ada exception catchpoint.
12043
12044 Note: Just for the purpose of inserting our Ada exception
12045 catchpoint, we could rely purely on the associated minimal symbol.
12046 But we would be operating in degraded mode anyway, since we are
12047 still lacking the debugging info needed later on to extract
12048 the name of the exception being raised (this name is printed in
12049 the catchpoint message, and is also used when trying to catch
12050 a specific exception). We do not handle this case for now. */
3b7344d5 12051 struct bound_minimal_symbol msym
1c8e84b0
JB
12052 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12053
3b7344d5 12054 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
12055 error (_("Your Ada runtime appears to be missing some debugging "
12056 "information.\nCannot insert Ada exception catchpoint "
12057 "in this configuration."));
12058
12059 return 0;
12060 }
f17011e0
JB
12061
12062 /* Make sure that the symbol we found corresponds to a function. */
12063
12064 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12065 error (_("Symbol \"%s\" is not a function (class = %d)"),
12066 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12067
12068 return 1;
12069}
12070
0259addd
JB
12071/* Inspect the Ada runtime and determine which exception info structure
12072 should be used to provide support for exception catchpoints.
12073
3eecfa55
JB
12074 This function will always set the per-inferior exception_info,
12075 or raise an error. */
0259addd
JB
12076
12077static void
12078ada_exception_support_info_sniffer (void)
12079{
3eecfa55 12080 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
12081
12082 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 12083 if (data->exception_info != NULL)
0259addd
JB
12084 return;
12085
12086 /* Check the latest (default) exception support info. */
f17011e0 12087 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 12088 {
3eecfa55 12089 data->exception_info = &default_exception_support_info;
0259addd
JB
12090 return;
12091 }
12092
12093 /* Try our fallback exception suport info. */
f17011e0 12094 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 12095 {
3eecfa55 12096 data->exception_info = &exception_support_info_fallback;
0259addd
JB
12097 return;
12098 }
12099
12100 /* Sometimes, it is normal for us to not be able to find the routine
12101 we are looking for. This happens when the program is linked with
12102 the shared version of the GNAT runtime, and the program has not been
12103 started yet. Inform the user of these two possible causes if
12104 applicable. */
12105
ccefe4c4 12106 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
12107 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12108
12109 /* If the symbol does not exist, then check that the program is
12110 already started, to make sure that shared libraries have been
12111 loaded. If it is not started, this may mean that the symbol is
12112 in a shared library. */
12113
e99b03dc 12114 if (inferior_ptid.pid () == 0)
0259addd
JB
12115 error (_("Unable to insert catchpoint. Try to start the program first."));
12116
12117 /* At this point, we know that we are debugging an Ada program and
12118 that the inferior has been started, but we still are not able to
0963b4bd 12119 find the run-time symbols. That can mean that we are in
0259addd
JB
12120 configurable run time mode, or that a-except as been optimized
12121 out by the linker... In any case, at this point it is not worth
12122 supporting this feature. */
12123
7dda8cff 12124 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12125}
12126
f7f9143b
JB
12127/* True iff FRAME is very likely to be that of a function that is
12128 part of the runtime system. This is all very heuristic, but is
12129 intended to be used as advice as to what frames are uninteresting
12130 to most users. */
12131
12132static int
12133is_known_support_routine (struct frame_info *frame)
12134{
692465f1 12135 enum language func_lang;
f7f9143b 12136 int i;
f35a17b5 12137 const char *fullname;
f7f9143b 12138
4ed6b5be
JB
12139 /* If this code does not have any debugging information (no symtab),
12140 This cannot be any user code. */
f7f9143b 12141
51abb421 12142 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12143 if (sal.symtab == NULL)
12144 return 1;
12145
4ed6b5be
JB
12146 /* If there is a symtab, but the associated source file cannot be
12147 located, then assume this is not user code: Selecting a frame
12148 for which we cannot display the code would not be very helpful
12149 for the user. This should also take care of case such as VxWorks
12150 where the kernel has some debugging info provided for a few units. */
f7f9143b 12151
f35a17b5
JK
12152 fullname = symtab_to_fullname (sal.symtab);
12153 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12154 return 1;
12155
4ed6b5be
JB
12156 /* Check the unit filename againt the Ada runtime file naming.
12157 We also check the name of the objfile against the name of some
12158 known system libraries that sometimes come with debugging info
12159 too. */
12160
f7f9143b
JB
12161 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12162 {
12163 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12164 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12165 return 1;
eb822aa6
DE
12166 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12167 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12168 return 1;
f7f9143b
JB
12169 }
12170
4ed6b5be 12171 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12172
c6dc63a1
TT
12173 gdb::unique_xmalloc_ptr<char> func_name
12174 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12175 if (func_name == NULL)
12176 return 1;
12177
12178 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12179 {
12180 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12181 if (re_exec (func_name.get ()))
12182 return 1;
f7f9143b
JB
12183 }
12184
12185 return 0;
12186}
12187
12188/* Find the first frame that contains debugging information and that is not
12189 part of the Ada run-time, starting from FI and moving upward. */
12190
0ef643c8 12191void
f7f9143b
JB
12192ada_find_printable_frame (struct frame_info *fi)
12193{
12194 for (; fi != NULL; fi = get_prev_frame (fi))
12195 {
12196 if (!is_known_support_routine (fi))
12197 {
12198 select_frame (fi);
12199 break;
12200 }
12201 }
12202
12203}
12204
12205/* Assuming that the inferior just triggered an unhandled exception
12206 catchpoint, return the address in inferior memory where the name
12207 of the exception is stored.
12208
12209 Return zero if the address could not be computed. */
12210
12211static CORE_ADDR
12212ada_unhandled_exception_name_addr (void)
0259addd
JB
12213{
12214 return parse_and_eval_address ("e.full_name");
12215}
12216
12217/* Same as ada_unhandled_exception_name_addr, except that this function
12218 should be used when the inferior uses an older version of the runtime,
12219 where the exception name needs to be extracted from a specific frame
12220 several frames up in the callstack. */
12221
12222static CORE_ADDR
12223ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12224{
12225 int frame_level;
12226 struct frame_info *fi;
3eecfa55 12227 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12228
12229 /* To determine the name of this exception, we need to select
12230 the frame corresponding to RAISE_SYM_NAME. This frame is
12231 at least 3 levels up, so we simply skip the first 3 frames
12232 without checking the name of their associated function. */
12233 fi = get_current_frame ();
12234 for (frame_level = 0; frame_level < 3; frame_level += 1)
12235 if (fi != NULL)
12236 fi = get_prev_frame (fi);
12237
12238 while (fi != NULL)
12239 {
692465f1
JB
12240 enum language func_lang;
12241
c6dc63a1
TT
12242 gdb::unique_xmalloc_ptr<char> func_name
12243 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12244 if (func_name != NULL)
12245 {
c6dc63a1 12246 if (strcmp (func_name.get (),
55b87a52
KS
12247 data->exception_info->catch_exception_sym) == 0)
12248 break; /* We found the frame we were looking for... */
55b87a52 12249 }
fb44b1a7 12250 fi = get_prev_frame (fi);
f7f9143b
JB
12251 }
12252
12253 if (fi == NULL)
12254 return 0;
12255
12256 select_frame (fi);
12257 return parse_and_eval_address ("id.full_name");
12258}
12259
12260/* Assuming the inferior just triggered an Ada exception catchpoint
12261 (of any type), return the address in inferior memory where the name
12262 of the exception is stored, if applicable.
12263
45db7c09
PA
12264 Assumes the selected frame is the current frame.
12265
f7f9143b
JB
12266 Return zero if the address could not be computed, or if not relevant. */
12267
12268static CORE_ADDR
761269c8 12269ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12270 struct breakpoint *b)
12271{
3eecfa55
JB
12272 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12273
f7f9143b
JB
12274 switch (ex)
12275 {
761269c8 12276 case ada_catch_exception:
f7f9143b
JB
12277 return (parse_and_eval_address ("e.full_name"));
12278 break;
12279
761269c8 12280 case ada_catch_exception_unhandled:
3eecfa55 12281 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12282 break;
9f757bf7
XR
12283
12284 case ada_catch_handlers:
12285 return 0; /* The runtimes does not provide access to the exception
12286 name. */
12287 break;
12288
761269c8 12289 case ada_catch_assert:
f7f9143b
JB
12290 return 0; /* Exception name is not relevant in this case. */
12291 break;
12292
12293 default:
12294 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12295 break;
12296 }
12297
12298 return 0; /* Should never be reached. */
12299}
12300
e547c119
JB
12301/* Assuming the inferior is stopped at an exception catchpoint,
12302 return the message which was associated to the exception, if
12303 available. Return NULL if the message could not be retrieved.
12304
e547c119
JB
12305 Note: The exception message can be associated to an exception
12306 either through the use of the Raise_Exception function, or
12307 more simply (Ada 2005 and later), via:
12308
12309 raise Exception_Name with "exception message";
12310
12311 */
12312
6f46ac85 12313static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12314ada_exception_message_1 (void)
12315{
12316 struct value *e_msg_val;
e547c119 12317 int e_msg_len;
e547c119
JB
12318
12319 /* For runtimes that support this feature, the exception message
12320 is passed as an unbounded string argument called "message". */
12321 e_msg_val = parse_and_eval ("message");
12322 if (e_msg_val == NULL)
12323 return NULL; /* Exception message not supported. */
12324
12325 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12326 gdb_assert (e_msg_val != NULL);
12327 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12328
12329 /* If the message string is empty, then treat it as if there was
12330 no exception message. */
12331 if (e_msg_len <= 0)
12332 return NULL;
12333
6f46ac85
TT
12334 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12335 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12336 e_msg.get ()[e_msg_len] = '\0';
e547c119 12337
e547c119
JB
12338 return e_msg;
12339}
12340
12341/* Same as ada_exception_message_1, except that all exceptions are
12342 contained here (returning NULL instead). */
12343
6f46ac85 12344static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12345ada_exception_message (void)
12346{
6f46ac85 12347 gdb::unique_xmalloc_ptr<char> e_msg;
e547c119
JB
12348
12349 TRY
12350 {
12351 e_msg = ada_exception_message_1 ();
12352 }
12353 CATCH (e, RETURN_MASK_ERROR)
12354 {
6f46ac85 12355 e_msg.reset (nullptr);
e547c119
JB
12356 }
12357 END_CATCH
12358
12359 return e_msg;
12360}
12361
f7f9143b
JB
12362/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12363 any error that ada_exception_name_addr_1 might cause to be thrown.
12364 When an error is intercepted, a warning with the error message is printed,
12365 and zero is returned. */
12366
12367static CORE_ADDR
761269c8 12368ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12369 struct breakpoint *b)
12370{
f7f9143b
JB
12371 CORE_ADDR result = 0;
12372
492d29ea 12373 TRY
f7f9143b
JB
12374 {
12375 result = ada_exception_name_addr_1 (ex, b);
12376 }
12377
492d29ea 12378 CATCH (e, RETURN_MASK_ERROR)
f7f9143b 12379 {
3d6e9d23 12380 warning (_("failed to get exception name: %s"), e.what ());
f7f9143b
JB
12381 return 0;
12382 }
492d29ea 12383 END_CATCH
f7f9143b
JB
12384
12385 return result;
12386}
12387
cb7de75e 12388static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12389 (const char *excep_string,
12390 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12391
12392/* Ada catchpoints.
12393
12394 In the case of catchpoints on Ada exceptions, the catchpoint will
12395 stop the target on every exception the program throws. When a user
12396 specifies the name of a specific exception, we translate this
12397 request into a condition expression (in text form), and then parse
12398 it into an expression stored in each of the catchpoint's locations.
12399 We then use this condition to check whether the exception that was
12400 raised is the one the user is interested in. If not, then the
12401 target is resumed again. We store the name of the requested
12402 exception, in order to be able to re-set the condition expression
12403 when symbols change. */
12404
12405/* An instance of this type is used to represent an Ada catchpoint
5625a286 12406 breakpoint location. */
28010a5d 12407
5625a286 12408class ada_catchpoint_location : public bp_location
28010a5d 12409{
5625a286 12410public:
5f486660
TT
12411 ada_catchpoint_location (breakpoint *owner)
12412 : bp_location (owner)
5625a286 12413 {}
28010a5d
PA
12414
12415 /* The condition that checks whether the exception that was raised
12416 is the specific exception the user specified on catchpoint
12417 creation. */
4d01a485 12418 expression_up excep_cond_expr;
28010a5d
PA
12419};
12420
c1fc2657 12421/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12422
c1fc2657 12423struct ada_catchpoint : public breakpoint
28010a5d 12424{
28010a5d 12425 /* The name of the specific exception the user specified. */
bc18fbb5 12426 std::string excep_string;
28010a5d
PA
12427};
12428
12429/* Parse the exception condition string in the context of each of the
12430 catchpoint's locations, and store them for later evaluation. */
12431
12432static void
9f757bf7
XR
12433create_excep_cond_exprs (struct ada_catchpoint *c,
12434 enum ada_exception_catchpoint_kind ex)
28010a5d 12435{
28010a5d 12436 struct bp_location *bl;
28010a5d
PA
12437
12438 /* Nothing to do if there's no specific exception to catch. */
bc18fbb5 12439 if (c->excep_string.empty ())
28010a5d
PA
12440 return;
12441
12442 /* Same if there are no locations... */
c1fc2657 12443 if (c->loc == NULL)
28010a5d
PA
12444 return;
12445
12446 /* Compute the condition expression in text form, from the specific
12447 expection we want to catch. */
cb7de75e 12448 std::string cond_string
bc18fbb5 12449 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
28010a5d
PA
12450
12451 /* Iterate over all the catchpoint's locations, and parse an
12452 expression for each. */
c1fc2657 12453 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12454 {
12455 struct ada_catchpoint_location *ada_loc
12456 = (struct ada_catchpoint_location *) bl;
4d01a485 12457 expression_up exp;
28010a5d
PA
12458
12459 if (!bl->shlib_disabled)
12460 {
bbc13ae3 12461 const char *s;
28010a5d 12462
cb7de75e 12463 s = cond_string.c_str ();
492d29ea 12464 TRY
28010a5d 12465 {
036e657b
JB
12466 exp = parse_exp_1 (&s, bl->address,
12467 block_for_pc (bl->address),
12468 0);
28010a5d 12469 }
492d29ea 12470 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12471 {
12472 warning (_("failed to reevaluate internal exception condition "
12473 "for catchpoint %d: %s"),
3d6e9d23 12474 c->number, e.what ());
849f2b52 12475 }
492d29ea 12476 END_CATCH
28010a5d
PA
12477 }
12478
b22e99fd 12479 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12480 }
28010a5d
PA
12481}
12482
28010a5d
PA
12483/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12484 structure for all exception catchpoint kinds. */
12485
12486static struct bp_location *
761269c8 12487allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12488 struct breakpoint *self)
12489{
5f486660 12490 return new ada_catchpoint_location (self);
28010a5d
PA
12491}
12492
12493/* Implement the RE_SET method in the breakpoint_ops structure for all
12494 exception catchpoint kinds. */
12495
12496static void
761269c8 12497re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12498{
12499 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12500
12501 /* Call the base class's method. This updates the catchpoint's
12502 locations. */
2060206e 12503 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12504
12505 /* Reparse the exception conditional expressions. One for each
12506 location. */
9f757bf7 12507 create_excep_cond_exprs (c, ex);
28010a5d
PA
12508}
12509
12510/* Returns true if we should stop for this breakpoint hit. If the
12511 user specified a specific exception, we only want to cause a stop
12512 if the program thrown that exception. */
12513
12514static int
12515should_stop_exception (const struct bp_location *bl)
12516{
12517 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12518 const struct ada_catchpoint_location *ada_loc
12519 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12520 int stop;
12521
12522 /* With no specific exception, should always stop. */
bc18fbb5 12523 if (c->excep_string.empty ())
28010a5d
PA
12524 return 1;
12525
12526 if (ada_loc->excep_cond_expr == NULL)
12527 {
12528 /* We will have a NULL expression if back when we were creating
12529 the expressions, this location's had failed to parse. */
12530 return 1;
12531 }
12532
12533 stop = 1;
492d29ea 12534 TRY
28010a5d
PA
12535 {
12536 struct value *mark;
12537
12538 mark = value_mark ();
4d01a485 12539 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12540 value_free_to_mark (mark);
12541 }
492d29ea
PA
12542 CATCH (ex, RETURN_MASK_ALL)
12543 {
12544 exception_fprintf (gdb_stderr, ex,
12545 _("Error in testing exception condition:\n"));
12546 }
12547 END_CATCH
12548
28010a5d
PA
12549 return stop;
12550}
12551
12552/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12553 for all exception catchpoint kinds. */
12554
12555static void
761269c8 12556check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12557{
12558 bs->stop = should_stop_exception (bs->bp_location_at);
12559}
12560
f7f9143b
JB
12561/* Implement the PRINT_IT method in the breakpoint_ops structure
12562 for all exception catchpoint kinds. */
12563
12564static enum print_stop_action
761269c8 12565print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12566{
79a45e25 12567 struct ui_out *uiout = current_uiout;
348d480f
PA
12568 struct breakpoint *b = bs->breakpoint_at;
12569
956a9fb9 12570 annotate_catchpoint (b->number);
f7f9143b 12571
112e8700 12572 if (uiout->is_mi_like_p ())
f7f9143b 12573 {
112e8700 12574 uiout->field_string ("reason",
956a9fb9 12575 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12576 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12577 }
12578
112e8700
SM
12579 uiout->text (b->disposition == disp_del
12580 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12581 uiout->field_int ("bkptno", b->number);
12582 uiout->text (", ");
f7f9143b 12583
45db7c09
PA
12584 /* ada_exception_name_addr relies on the selected frame being the
12585 current frame. Need to do this here because this function may be
12586 called more than once when printing a stop, and below, we'll
12587 select the first frame past the Ada run-time (see
12588 ada_find_printable_frame). */
12589 select_frame (get_current_frame ());
12590
f7f9143b
JB
12591 switch (ex)
12592 {
761269c8
JB
12593 case ada_catch_exception:
12594 case ada_catch_exception_unhandled:
9f757bf7 12595 case ada_catch_handlers:
956a9fb9
JB
12596 {
12597 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12598 char exception_name[256];
12599
12600 if (addr != 0)
12601 {
c714b426
PA
12602 read_memory (addr, (gdb_byte *) exception_name,
12603 sizeof (exception_name) - 1);
956a9fb9
JB
12604 exception_name [sizeof (exception_name) - 1] = '\0';
12605 }
12606 else
12607 {
12608 /* For some reason, we were unable to read the exception
12609 name. This could happen if the Runtime was compiled
12610 without debugging info, for instance. In that case,
12611 just replace the exception name by the generic string
12612 "exception" - it will read as "an exception" in the
12613 notification we are about to print. */
967cff16 12614 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12615 }
12616 /* In the case of unhandled exception breakpoints, we print
12617 the exception name as "unhandled EXCEPTION_NAME", to make
12618 it clearer to the user which kind of catchpoint just got
12619 hit. We used ui_out_text to make sure that this extra
12620 info does not pollute the exception name in the MI case. */
761269c8 12621 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12622 uiout->text ("unhandled ");
12623 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12624 }
12625 break;
761269c8 12626 case ada_catch_assert:
956a9fb9
JB
12627 /* In this case, the name of the exception is not really
12628 important. Just print "failed assertion" to make it clearer
12629 that his program just hit an assertion-failure catchpoint.
12630 We used ui_out_text because this info does not belong in
12631 the MI output. */
112e8700 12632 uiout->text ("failed assertion");
956a9fb9 12633 break;
f7f9143b 12634 }
e547c119 12635
6f46ac85 12636 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
e547c119
JB
12637 if (exception_message != NULL)
12638 {
e547c119 12639 uiout->text (" (");
6f46ac85 12640 uiout->field_string ("exception-message", exception_message.get ());
e547c119 12641 uiout->text (")");
e547c119
JB
12642 }
12643
112e8700 12644 uiout->text (" at ");
956a9fb9 12645 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12646
12647 return PRINT_SRC_AND_LOC;
12648}
12649
12650/* Implement the PRINT_ONE method in the breakpoint_ops structure
12651 for all exception catchpoint kinds. */
12652
12653static void
761269c8 12654print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12655 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12656{
79a45e25 12657 struct ui_out *uiout = current_uiout;
28010a5d 12658 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12659 struct value_print_options opts;
12660
12661 get_user_print_options (&opts);
12662 if (opts.addressprint)
f7f9143b
JB
12663 {
12664 annotate_field (4);
112e8700 12665 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12666 }
12667
12668 annotate_field (5);
a6d9a66e 12669 *last_loc = b->loc;
f7f9143b
JB
12670 switch (ex)
12671 {
761269c8 12672 case ada_catch_exception:
bc18fbb5 12673 if (!c->excep_string.empty ())
f7f9143b 12674 {
bc18fbb5
TT
12675 std::string msg = string_printf (_("`%s' Ada exception"),
12676 c->excep_string.c_str ());
28010a5d 12677
112e8700 12678 uiout->field_string ("what", msg);
f7f9143b
JB
12679 }
12680 else
112e8700 12681 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12682
12683 break;
12684
761269c8 12685 case ada_catch_exception_unhandled:
112e8700 12686 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12687 break;
12688
9f757bf7 12689 case ada_catch_handlers:
bc18fbb5 12690 if (!c->excep_string.empty ())
9f757bf7
XR
12691 {
12692 uiout->field_fmt ("what",
12693 _("`%s' Ada exception handlers"),
bc18fbb5 12694 c->excep_string.c_str ());
9f757bf7
XR
12695 }
12696 else
12697 uiout->field_string ("what", "all Ada exceptions handlers");
12698 break;
12699
761269c8 12700 case ada_catch_assert:
112e8700 12701 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12702 break;
12703
12704 default:
12705 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12706 break;
12707 }
12708}
12709
12710/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12711 for all exception catchpoint kinds. */
12712
12713static void
761269c8 12714print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12715 struct breakpoint *b)
12716{
28010a5d 12717 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12718 struct ui_out *uiout = current_uiout;
28010a5d 12719
112e8700 12720 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12721 : _("Catchpoint "));
112e8700
SM
12722 uiout->field_int ("bkptno", b->number);
12723 uiout->text (": ");
00eb2c4a 12724
f7f9143b
JB
12725 switch (ex)
12726 {
761269c8 12727 case ada_catch_exception:
bc18fbb5 12728 if (!c->excep_string.empty ())
00eb2c4a 12729 {
862d101a 12730 std::string info = string_printf (_("`%s' Ada exception"),
bc18fbb5 12731 c->excep_string.c_str ());
862d101a 12732 uiout->text (info.c_str ());
00eb2c4a 12733 }
f7f9143b 12734 else
112e8700 12735 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12736 break;
12737
761269c8 12738 case ada_catch_exception_unhandled:
112e8700 12739 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12740 break;
9f757bf7
XR
12741
12742 case ada_catch_handlers:
bc18fbb5 12743 if (!c->excep_string.empty ())
9f757bf7
XR
12744 {
12745 std::string info
12746 = string_printf (_("`%s' Ada exception handlers"),
bc18fbb5 12747 c->excep_string.c_str ());
9f757bf7
XR
12748 uiout->text (info.c_str ());
12749 }
12750 else
12751 uiout->text (_("all Ada exceptions handlers"));
12752 break;
12753
761269c8 12754 case ada_catch_assert:
112e8700 12755 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12756 break;
12757
12758 default:
12759 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12760 break;
12761 }
12762}
12763
6149aea9
PA
12764/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12765 for all exception catchpoint kinds. */
12766
12767static void
761269c8 12768print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12769 struct breakpoint *b, struct ui_file *fp)
12770{
28010a5d
PA
12771 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12772
6149aea9
PA
12773 switch (ex)
12774 {
761269c8 12775 case ada_catch_exception:
6149aea9 12776 fprintf_filtered (fp, "catch exception");
bc18fbb5
TT
12777 if (!c->excep_string.empty ())
12778 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
6149aea9
PA
12779 break;
12780
761269c8 12781 case ada_catch_exception_unhandled:
78076abc 12782 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12783 break;
12784
9f757bf7
XR
12785 case ada_catch_handlers:
12786 fprintf_filtered (fp, "catch handlers");
12787 break;
12788
761269c8 12789 case ada_catch_assert:
6149aea9
PA
12790 fprintf_filtered (fp, "catch assert");
12791 break;
12792
12793 default:
12794 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12795 }
d9b3f62e 12796 print_recreate_thread (b, fp);
6149aea9
PA
12797}
12798
f7f9143b
JB
12799/* Virtual table for "catch exception" breakpoints. */
12800
28010a5d
PA
12801static struct bp_location *
12802allocate_location_catch_exception (struct breakpoint *self)
12803{
761269c8 12804 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12805}
12806
12807static void
12808re_set_catch_exception (struct breakpoint *b)
12809{
761269c8 12810 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12811}
12812
12813static void
12814check_status_catch_exception (bpstat bs)
12815{
761269c8 12816 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12817}
12818
f7f9143b 12819static enum print_stop_action
348d480f 12820print_it_catch_exception (bpstat bs)
f7f9143b 12821{
761269c8 12822 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12823}
12824
12825static void
a6d9a66e 12826print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12827{
761269c8 12828 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12829}
12830
12831static void
12832print_mention_catch_exception (struct breakpoint *b)
12833{
761269c8 12834 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12835}
12836
6149aea9
PA
12837static void
12838print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12839{
761269c8 12840 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12841}
12842
2060206e 12843static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12844
12845/* Virtual table for "catch exception unhandled" breakpoints. */
12846
28010a5d
PA
12847static struct bp_location *
12848allocate_location_catch_exception_unhandled (struct breakpoint *self)
12849{
761269c8 12850 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12851}
12852
12853static void
12854re_set_catch_exception_unhandled (struct breakpoint *b)
12855{
761269c8 12856 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12857}
12858
12859static void
12860check_status_catch_exception_unhandled (bpstat bs)
12861{
761269c8 12862 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12863}
12864
f7f9143b 12865static enum print_stop_action
348d480f 12866print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12867{
761269c8 12868 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12869}
12870
12871static void
a6d9a66e
UW
12872print_one_catch_exception_unhandled (struct breakpoint *b,
12873 struct bp_location **last_loc)
f7f9143b 12874{
761269c8 12875 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12876}
12877
12878static void
12879print_mention_catch_exception_unhandled (struct breakpoint *b)
12880{
761269c8 12881 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12882}
12883
6149aea9
PA
12884static void
12885print_recreate_catch_exception_unhandled (struct breakpoint *b,
12886 struct ui_file *fp)
12887{
761269c8 12888 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12889}
12890
2060206e 12891static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12892
12893/* Virtual table for "catch assert" breakpoints. */
12894
28010a5d
PA
12895static struct bp_location *
12896allocate_location_catch_assert (struct breakpoint *self)
12897{
761269c8 12898 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12899}
12900
12901static void
12902re_set_catch_assert (struct breakpoint *b)
12903{
761269c8 12904 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12905}
12906
12907static void
12908check_status_catch_assert (bpstat bs)
12909{
761269c8 12910 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12911}
12912
f7f9143b 12913static enum print_stop_action
348d480f 12914print_it_catch_assert (bpstat bs)
f7f9143b 12915{
761269c8 12916 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12917}
12918
12919static void
a6d9a66e 12920print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12921{
761269c8 12922 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12923}
12924
12925static void
12926print_mention_catch_assert (struct breakpoint *b)
12927{
761269c8 12928 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12929}
12930
6149aea9
PA
12931static void
12932print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12933{
761269c8 12934 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12935}
12936
2060206e 12937static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12938
9f757bf7
XR
12939/* Virtual table for "catch handlers" breakpoints. */
12940
12941static struct bp_location *
12942allocate_location_catch_handlers (struct breakpoint *self)
12943{
12944 return allocate_location_exception (ada_catch_handlers, self);
12945}
12946
12947static void
12948re_set_catch_handlers (struct breakpoint *b)
12949{
12950 re_set_exception (ada_catch_handlers, b);
12951}
12952
12953static void
12954check_status_catch_handlers (bpstat bs)
12955{
12956 check_status_exception (ada_catch_handlers, bs);
12957}
12958
12959static enum print_stop_action
12960print_it_catch_handlers (bpstat bs)
12961{
12962 return print_it_exception (ada_catch_handlers, bs);
12963}
12964
12965static void
12966print_one_catch_handlers (struct breakpoint *b,
12967 struct bp_location **last_loc)
12968{
12969 print_one_exception (ada_catch_handlers, b, last_loc);
12970}
12971
12972static void
12973print_mention_catch_handlers (struct breakpoint *b)
12974{
12975 print_mention_exception (ada_catch_handlers, b);
12976}
12977
12978static void
12979print_recreate_catch_handlers (struct breakpoint *b,
12980 struct ui_file *fp)
12981{
12982 print_recreate_exception (ada_catch_handlers, b, fp);
12983}
12984
12985static struct breakpoint_ops catch_handlers_breakpoint_ops;
12986
f7f9143b
JB
12987/* Split the arguments specified in a "catch exception" command.
12988 Set EX to the appropriate catchpoint type.
28010a5d 12989 Set EXCEP_STRING to the name of the specific exception if
5845583d 12990 specified by the user.
9f757bf7
XR
12991 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12992 "catch handlers" command. False otherwise.
5845583d
JB
12993 If a condition is found at the end of the arguments, the condition
12994 expression is stored in COND_STRING (memory must be deallocated
12995 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12996
12997static void
a121b7c1 12998catch_ada_exception_command_split (const char *args,
9f757bf7 12999 bool is_catch_handlers_cmd,
761269c8 13000 enum ada_exception_catchpoint_kind *ex,
bc18fbb5
TT
13001 std::string *excep_string,
13002 std::string *cond_string)
f7f9143b 13003{
bc18fbb5 13004 std::string exception_name;
f7f9143b 13005
bc18fbb5
TT
13006 exception_name = extract_arg (&args);
13007 if (exception_name == "if")
5845583d
JB
13008 {
13009 /* This is not an exception name; this is the start of a condition
13010 expression for a catchpoint on all exceptions. So, "un-get"
13011 this token, and set exception_name to NULL. */
bc18fbb5 13012 exception_name.clear ();
5845583d
JB
13013 args -= 2;
13014 }
f7f9143b 13015
5845583d 13016 /* Check to see if we have a condition. */
f7f9143b 13017
f1735a53 13018 args = skip_spaces (args);
61012eef 13019 if (startswith (args, "if")
5845583d
JB
13020 && (isspace (args[2]) || args[2] == '\0'))
13021 {
13022 args += 2;
f1735a53 13023 args = skip_spaces (args);
5845583d
JB
13024
13025 if (args[0] == '\0')
13026 error (_("Condition missing after `if' keyword"));
bc18fbb5 13027 *cond_string = args;
5845583d
JB
13028
13029 args += strlen (args);
13030 }
13031
13032 /* Check that we do not have any more arguments. Anything else
13033 is unexpected. */
f7f9143b
JB
13034
13035 if (args[0] != '\0')
13036 error (_("Junk at end of expression"));
13037
9f757bf7
XR
13038 if (is_catch_handlers_cmd)
13039 {
13040 /* Catch handling of exceptions. */
13041 *ex = ada_catch_handlers;
13042 *excep_string = exception_name;
13043 }
bc18fbb5 13044 else if (exception_name.empty ())
f7f9143b
JB
13045 {
13046 /* Catch all exceptions. */
761269c8 13047 *ex = ada_catch_exception;
bc18fbb5 13048 excep_string->clear ();
f7f9143b 13049 }
bc18fbb5 13050 else if (exception_name == "unhandled")
f7f9143b
JB
13051 {
13052 /* Catch unhandled exceptions. */
761269c8 13053 *ex = ada_catch_exception_unhandled;
bc18fbb5 13054 excep_string->clear ();
f7f9143b
JB
13055 }
13056 else
13057 {
13058 /* Catch a specific exception. */
761269c8 13059 *ex = ada_catch_exception;
28010a5d 13060 *excep_string = exception_name;
f7f9143b
JB
13061 }
13062}
13063
13064/* Return the name of the symbol on which we should break in order to
13065 implement a catchpoint of the EX kind. */
13066
13067static const char *
761269c8 13068ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 13069{
3eecfa55
JB
13070 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13071
13072 gdb_assert (data->exception_info != NULL);
0259addd 13073
f7f9143b
JB
13074 switch (ex)
13075 {
761269c8 13076 case ada_catch_exception:
3eecfa55 13077 return (data->exception_info->catch_exception_sym);
f7f9143b 13078 break;
761269c8 13079 case ada_catch_exception_unhandled:
3eecfa55 13080 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 13081 break;
761269c8 13082 case ada_catch_assert:
3eecfa55 13083 return (data->exception_info->catch_assert_sym);
f7f9143b 13084 break;
9f757bf7
XR
13085 case ada_catch_handlers:
13086 return (data->exception_info->catch_handlers_sym);
13087 break;
f7f9143b
JB
13088 default:
13089 internal_error (__FILE__, __LINE__,
13090 _("unexpected catchpoint kind (%d)"), ex);
13091 }
13092}
13093
13094/* Return the breakpoint ops "virtual table" used for catchpoints
13095 of the EX kind. */
13096
c0a91b2b 13097static const struct breakpoint_ops *
761269c8 13098ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
13099{
13100 switch (ex)
13101 {
761269c8 13102 case ada_catch_exception:
f7f9143b
JB
13103 return (&catch_exception_breakpoint_ops);
13104 break;
761269c8 13105 case ada_catch_exception_unhandled:
f7f9143b
JB
13106 return (&catch_exception_unhandled_breakpoint_ops);
13107 break;
761269c8 13108 case ada_catch_assert:
f7f9143b
JB
13109 return (&catch_assert_breakpoint_ops);
13110 break;
9f757bf7
XR
13111 case ada_catch_handlers:
13112 return (&catch_handlers_breakpoint_ops);
13113 break;
f7f9143b
JB
13114 default:
13115 internal_error (__FILE__, __LINE__,
13116 _("unexpected catchpoint kind (%d)"), ex);
13117 }
13118}
13119
13120/* Return the condition that will be used to match the current exception
13121 being raised with the exception that the user wants to catch. This
13122 assumes that this condition is used when the inferior just triggered
13123 an exception catchpoint.
cb7de75e 13124 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 13125
cb7de75e 13126static std::string
9f757bf7
XR
13127ada_exception_catchpoint_cond_string (const char *excep_string,
13128 enum ada_exception_catchpoint_kind ex)
f7f9143b 13129{
3d0b0fa3 13130 int i;
9f757bf7 13131 bool is_standard_exc = false;
cb7de75e 13132 std::string result;
9f757bf7
XR
13133
13134 if (ex == ada_catch_handlers)
13135 {
13136 /* For exception handlers catchpoints, the condition string does
13137 not use the same parameter as for the other exceptions. */
cb7de75e
TT
13138 result = ("long_integer (GNAT_GCC_exception_Access"
13139 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13140 }
13141 else
cb7de75e 13142 result = "long_integer (e)";
3d0b0fa3 13143
0963b4bd 13144 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13145 runtime units that have been compiled without debugging info; if
28010a5d 13146 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13147 exception (e.g. "constraint_error") then, during the evaluation
13148 of the condition expression, the symbol lookup on this name would
0963b4bd 13149 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13150 may then be set only on user-defined exceptions which have the
13151 same not-fully-qualified name (e.g. my_package.constraint_error).
13152
13153 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13154 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13155 exception constraint_error" is rewritten into "catch exception
13156 standard.constraint_error".
13157
13158 If an exception named contraint_error is defined in another package of
13159 the inferior program, then the only way to specify this exception as a
13160 breakpoint condition is to use its fully-qualified named:
13161 e.g. my_package.constraint_error. */
13162
13163 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13164 {
28010a5d 13165 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13166 {
9f757bf7
XR
13167 is_standard_exc = true;
13168 break;
3d0b0fa3
JB
13169 }
13170 }
9f757bf7 13171
cb7de75e
TT
13172 result += " = ";
13173
9f757bf7 13174 if (is_standard_exc)
cb7de75e 13175 string_appendf (result, "long_integer (&standard.%s)", excep_string);
9f757bf7 13176 else
cb7de75e 13177 string_appendf (result, "long_integer (&%s)", excep_string);
9f757bf7 13178
9f757bf7 13179 return result;
f7f9143b
JB
13180}
13181
13182/* Return the symtab_and_line that should be used to insert an exception
13183 catchpoint of the TYPE kind.
13184
28010a5d
PA
13185 ADDR_STRING returns the name of the function where the real
13186 breakpoint that implements the catchpoints is set, depending on the
13187 type of catchpoint we need to create. */
f7f9143b
JB
13188
13189static struct symtab_and_line
bc18fbb5 13190ada_exception_sal (enum ada_exception_catchpoint_kind ex,
cc12f4a8 13191 std::string *addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13192{
13193 const char *sym_name;
13194 struct symbol *sym;
f7f9143b 13195
0259addd
JB
13196 /* First, find out which exception support info to use. */
13197 ada_exception_support_info_sniffer ();
13198
13199 /* Then lookup the function on which we will break in order to catch
f7f9143b 13200 the Ada exceptions requested by the user. */
f7f9143b
JB
13201 sym_name = ada_exception_sym_name (ex);
13202 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13203
57aff202
JB
13204 if (sym == NULL)
13205 error (_("Catchpoint symbol not found: %s"), sym_name);
13206
13207 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13208 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
f7f9143b
JB
13209
13210 /* Set ADDR_STRING. */
cc12f4a8 13211 *addr_string = sym_name;
f7f9143b 13212
f7f9143b 13213 /* Set OPS. */
4b9eee8c 13214 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13215
f17011e0 13216 return find_function_start_sal (sym, 1);
f7f9143b
JB
13217}
13218
b4a5b78b 13219/* Create an Ada exception catchpoint.
f7f9143b 13220
b4a5b78b 13221 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13222
bc18fbb5 13223 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
2df4d1d5 13224 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
bc18fbb5 13225 of the exception to which this catchpoint applies.
2df4d1d5 13226
bc18fbb5 13227 COND_STRING, if not empty, is the catchpoint condition.
f7f9143b 13228
b4a5b78b
JB
13229 TEMPFLAG, if nonzero, means that the underlying breakpoint
13230 should be temporary.
28010a5d 13231
b4a5b78b 13232 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13233
349774ef 13234void
28010a5d 13235create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13236 enum ada_exception_catchpoint_kind ex_kind,
bc18fbb5 13237 const std::string &excep_string,
56ecd069 13238 const std::string &cond_string,
28010a5d 13239 int tempflag,
349774ef 13240 int disabled,
28010a5d
PA
13241 int from_tty)
13242{
cc12f4a8 13243 std::string addr_string;
b4a5b78b 13244 const struct breakpoint_ops *ops = NULL;
bc18fbb5 13245 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
28010a5d 13246
b270e6f9 13247 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
cc12f4a8 13248 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
349774ef 13249 ops, tempflag, disabled, from_tty);
28010a5d 13250 c->excep_string = excep_string;
9f757bf7 13251 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13252 if (!cond_string.empty ())
13253 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13254 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13255}
13256
9ac4176b
PA
13257/* Implement the "catch exception" command. */
13258
13259static void
eb4c3f4a 13260catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13261 struct cmd_list_element *command)
13262{
a121b7c1 13263 const char *arg = arg_entry;
9ac4176b
PA
13264 struct gdbarch *gdbarch = get_current_arch ();
13265 int tempflag;
761269c8 13266 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13267 std::string excep_string;
56ecd069 13268 std::string cond_string;
9ac4176b
PA
13269
13270 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13271
13272 if (!arg)
13273 arg = "";
9f757bf7 13274 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
bc18fbb5 13275 &cond_string);
9f757bf7
XR
13276 create_ada_exception_catchpoint (gdbarch, ex_kind,
13277 excep_string, cond_string,
13278 tempflag, 1 /* enabled */,
13279 from_tty);
13280}
13281
13282/* Implement the "catch handlers" command. */
13283
13284static void
13285catch_ada_handlers_command (const char *arg_entry, int from_tty,
13286 struct cmd_list_element *command)
13287{
13288 const char *arg = arg_entry;
13289 struct gdbarch *gdbarch = get_current_arch ();
13290 int tempflag;
13291 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13292 std::string excep_string;
56ecd069 13293 std::string cond_string;
9f757bf7
XR
13294
13295 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13296
13297 if (!arg)
13298 arg = "";
13299 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
bc18fbb5 13300 &cond_string);
b4a5b78b
JB
13301 create_ada_exception_catchpoint (gdbarch, ex_kind,
13302 excep_string, cond_string,
349774ef
JB
13303 tempflag, 1 /* enabled */,
13304 from_tty);
9ac4176b
PA
13305}
13306
b4a5b78b 13307/* Split the arguments specified in a "catch assert" command.
5845583d 13308
b4a5b78b
JB
13309 ARGS contains the command's arguments (or the empty string if
13310 no arguments were passed).
5845583d
JB
13311
13312 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13313 (the memory needs to be deallocated after use). */
5845583d 13314
b4a5b78b 13315static void
56ecd069 13316catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13317{
f1735a53 13318 args = skip_spaces (args);
f7f9143b 13319
5845583d 13320 /* Check whether a condition was provided. */
61012eef 13321 if (startswith (args, "if")
5845583d 13322 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13323 {
5845583d 13324 args += 2;
f1735a53 13325 args = skip_spaces (args);
5845583d
JB
13326 if (args[0] == '\0')
13327 error (_("condition missing after `if' keyword"));
56ecd069 13328 cond_string.assign (args);
f7f9143b
JB
13329 }
13330
5845583d
JB
13331 /* Otherwise, there should be no other argument at the end of
13332 the command. */
13333 else if (args[0] != '\0')
13334 error (_("Junk at end of arguments."));
f7f9143b
JB
13335}
13336
9ac4176b
PA
13337/* Implement the "catch assert" command. */
13338
13339static void
eb4c3f4a 13340catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13341 struct cmd_list_element *command)
13342{
a121b7c1 13343 const char *arg = arg_entry;
9ac4176b
PA
13344 struct gdbarch *gdbarch = get_current_arch ();
13345 int tempflag;
56ecd069 13346 std::string cond_string;
9ac4176b
PA
13347
13348 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13349
13350 if (!arg)
13351 arg = "";
56ecd069 13352 catch_ada_assert_command_split (arg, cond_string);
761269c8 13353 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
241db429 13354 "", cond_string,
349774ef
JB
13355 tempflag, 1 /* enabled */,
13356 from_tty);
9ac4176b 13357}
778865d3
JB
13358
13359/* Return non-zero if the symbol SYM is an Ada exception object. */
13360
13361static int
13362ada_is_exception_sym (struct symbol *sym)
13363{
a737d952 13364 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
778865d3
JB
13365
13366 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13367 && SYMBOL_CLASS (sym) != LOC_BLOCK
13368 && SYMBOL_CLASS (sym) != LOC_CONST
13369 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13370 && type_name != NULL && strcmp (type_name, "exception") == 0);
13371}
13372
13373/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13374 Ada exception object. This matches all exceptions except the ones
13375 defined by the Ada language. */
13376
13377static int
13378ada_is_non_standard_exception_sym (struct symbol *sym)
13379{
13380 int i;
13381
13382 if (!ada_is_exception_sym (sym))
13383 return 0;
13384
13385 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13386 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13387 return 0; /* A standard exception. */
13388
13389 /* Numeric_Error is also a standard exception, so exclude it.
13390 See the STANDARD_EXC description for more details as to why
13391 this exception is not listed in that array. */
13392 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13393 return 0;
13394
13395 return 1;
13396}
13397
ab816a27 13398/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13399 objects.
13400
13401 The comparison is determined first by exception name, and then
13402 by exception address. */
13403
ab816a27 13404bool
cc536b21 13405ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13406{
778865d3
JB
13407 int result;
13408
ab816a27
TT
13409 result = strcmp (name, other.name);
13410 if (result < 0)
13411 return true;
13412 if (result == 0 && addr < other.addr)
13413 return true;
13414 return false;
13415}
778865d3 13416
ab816a27 13417bool
cc536b21 13418ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13419{
13420 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13421}
13422
13423/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13424 routine, but keeping the first SKIP elements untouched.
13425
13426 All duplicates are also removed. */
13427
13428static void
ab816a27 13429sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13430 int skip)
13431{
ab816a27
TT
13432 std::sort (exceptions->begin () + skip, exceptions->end ());
13433 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13434 exceptions->end ());
778865d3
JB
13435}
13436
778865d3
JB
13437/* Add all exceptions defined by the Ada standard whose name match
13438 a regular expression.
13439
13440 If PREG is not NULL, then this regexp_t object is used to
13441 perform the symbol name matching. Otherwise, no name-based
13442 filtering is performed.
13443
13444 EXCEPTIONS is a vector of exceptions to which matching exceptions
13445 gets pushed. */
13446
13447static void
2d7cc5c7 13448ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13449 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13450{
13451 int i;
13452
13453 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13454 {
13455 if (preg == NULL
2d7cc5c7 13456 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13457 {
13458 struct bound_minimal_symbol msymbol
13459 = ada_lookup_simple_minsym (standard_exc[i]);
13460
13461 if (msymbol.minsym != NULL)
13462 {
13463 struct ada_exc_info info
77e371c0 13464 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13465
ab816a27 13466 exceptions->push_back (info);
778865d3
JB
13467 }
13468 }
13469 }
13470}
13471
13472/* Add all Ada exceptions defined locally and accessible from the given
13473 FRAME.
13474
13475 If PREG is not NULL, then this regexp_t object is used to
13476 perform the symbol name matching. Otherwise, no name-based
13477 filtering is performed.
13478
13479 EXCEPTIONS is a vector of exceptions to which matching exceptions
13480 gets pushed. */
13481
13482static void
2d7cc5c7
PA
13483ada_add_exceptions_from_frame (compiled_regex *preg,
13484 struct frame_info *frame,
ab816a27 13485 std::vector<ada_exc_info> *exceptions)
778865d3 13486{
3977b71f 13487 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13488
13489 while (block != 0)
13490 {
13491 struct block_iterator iter;
13492 struct symbol *sym;
13493
13494 ALL_BLOCK_SYMBOLS (block, iter, sym)
13495 {
13496 switch (SYMBOL_CLASS (sym))
13497 {
13498 case LOC_TYPEDEF:
13499 case LOC_BLOCK:
13500 case LOC_CONST:
13501 break;
13502 default:
13503 if (ada_is_exception_sym (sym))
13504 {
13505 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13506 SYMBOL_VALUE_ADDRESS (sym)};
13507
ab816a27 13508 exceptions->push_back (info);
778865d3
JB
13509 }
13510 }
13511 }
13512 if (BLOCK_FUNCTION (block) != NULL)
13513 break;
13514 block = BLOCK_SUPERBLOCK (block);
13515 }
13516}
13517
14bc53a8
PA
13518/* Return true if NAME matches PREG or if PREG is NULL. */
13519
13520static bool
2d7cc5c7 13521name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13522{
13523 return (preg == NULL
2d7cc5c7 13524 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13525}
13526
778865d3
JB
13527/* Add all exceptions defined globally whose name name match
13528 a regular expression, excluding standard exceptions.
13529
13530 The reason we exclude standard exceptions is that they need
13531 to be handled separately: Standard exceptions are defined inside
13532 a runtime unit which is normally not compiled with debugging info,
13533 and thus usually do not show up in our symbol search. However,
13534 if the unit was in fact built with debugging info, we need to
13535 exclude them because they would duplicate the entry we found
13536 during the special loop that specifically searches for those
13537 standard exceptions.
13538
13539 If PREG is not NULL, then this regexp_t object is used to
13540 perform the symbol name matching. Otherwise, no name-based
13541 filtering is performed.
13542
13543 EXCEPTIONS is a vector of exceptions to which matching exceptions
13544 gets pushed. */
13545
13546static void
2d7cc5c7 13547ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13548 std::vector<ada_exc_info> *exceptions)
778865d3 13549{
14bc53a8
PA
13550 /* In Ada, the symbol "search name" is a linkage name, whereas the
13551 regular expression used to do the matching refers to the natural
13552 name. So match against the decoded name. */
13553 expand_symtabs_matching (NULL,
b5ec771e 13554 lookup_name_info::match_any (),
14bc53a8
PA
13555 [&] (const char *search_name)
13556 {
13557 const char *decoded = ada_decode (search_name);
13558 return name_matches_regex (decoded, preg);
13559 },
13560 NULL,
13561 VARIABLES_DOMAIN);
778865d3 13562
2030c079 13563 for (objfile *objfile : current_program_space->objfiles ())
778865d3 13564 {
b669c953 13565 for (compunit_symtab *s : objfile->compunits ())
778865d3 13566 {
d8aeb77f
TT
13567 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13568 int i;
778865d3 13569
d8aeb77f
TT
13570 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13571 {
582942f4 13572 const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
d8aeb77f
TT
13573 struct block_iterator iter;
13574 struct symbol *sym;
778865d3 13575
d8aeb77f
TT
13576 ALL_BLOCK_SYMBOLS (b, iter, sym)
13577 if (ada_is_non_standard_exception_sym (sym)
13578 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13579 {
13580 struct ada_exc_info info
13581 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13582
13583 exceptions->push_back (info);
13584 }
13585 }
778865d3
JB
13586 }
13587 }
13588}
13589
13590/* Implements ada_exceptions_list with the regular expression passed
13591 as a regex_t, rather than a string.
13592
13593 If not NULL, PREG is used to filter out exceptions whose names
13594 do not match. Otherwise, all exceptions are listed. */
13595
ab816a27 13596static std::vector<ada_exc_info>
2d7cc5c7 13597ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13598{
ab816a27 13599 std::vector<ada_exc_info> result;
778865d3
JB
13600 int prev_len;
13601
13602 /* First, list the known standard exceptions. These exceptions
13603 need to be handled separately, as they are usually defined in
13604 runtime units that have been compiled without debugging info. */
13605
13606 ada_add_standard_exceptions (preg, &result);
13607
13608 /* Next, find all exceptions whose scope is local and accessible
13609 from the currently selected frame. */
13610
13611 if (has_stack_frames ())
13612 {
ab816a27 13613 prev_len = result.size ();
778865d3
JB
13614 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13615 &result);
ab816a27 13616 if (result.size () > prev_len)
778865d3
JB
13617 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13618 }
13619
13620 /* Add all exceptions whose scope is global. */
13621
ab816a27 13622 prev_len = result.size ();
778865d3 13623 ada_add_global_exceptions (preg, &result);
ab816a27 13624 if (result.size () > prev_len)
778865d3
JB
13625 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13626
778865d3
JB
13627 return result;
13628}
13629
13630/* Return a vector of ada_exc_info.
13631
13632 If REGEXP is NULL, all exceptions are included in the result.
13633 Otherwise, it should contain a valid regular expression,
13634 and only the exceptions whose names match that regular expression
13635 are included in the result.
13636
13637 The exceptions are sorted in the following order:
13638 - Standard exceptions (defined by the Ada language), in
13639 alphabetical order;
13640 - Exceptions only visible from the current frame, in
13641 alphabetical order;
13642 - Exceptions whose scope is global, in alphabetical order. */
13643
ab816a27 13644std::vector<ada_exc_info>
778865d3
JB
13645ada_exceptions_list (const char *regexp)
13646{
2d7cc5c7
PA
13647 if (regexp == NULL)
13648 return ada_exceptions_list_1 (NULL);
778865d3 13649
2d7cc5c7
PA
13650 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13651 return ada_exceptions_list_1 (&reg);
778865d3
JB
13652}
13653
13654/* Implement the "info exceptions" command. */
13655
13656static void
1d12d88f 13657info_exceptions_command (const char *regexp, int from_tty)
778865d3 13658{
778865d3 13659 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13660
ab816a27 13661 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13662
13663 if (regexp != NULL)
13664 printf_filtered
13665 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13666 else
13667 printf_filtered (_("All defined Ada exceptions:\n"));
13668
ab816a27
TT
13669 for (const ada_exc_info &info : exceptions)
13670 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13671}
13672
4c4b4cd2
PH
13673 /* Operators */
13674/* Information about operators given special treatment in functions
13675 below. */
13676/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13677
13678#define ADA_OPERATORS \
13679 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13680 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13681 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13682 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13683 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13684 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13685 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13686 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13687 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13688 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13689 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13690 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13691 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13692 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13693 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13694 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13695 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13696 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13697 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13698
13699static void
554794dc
SDJ
13700ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13701 int *argsp)
4c4b4cd2
PH
13702{
13703 switch (exp->elts[pc - 1].opcode)
13704 {
76a01679 13705 default:
4c4b4cd2
PH
13706 operator_length_standard (exp, pc, oplenp, argsp);
13707 break;
13708
13709#define OP_DEFN(op, len, args, binop) \
13710 case op: *oplenp = len; *argsp = args; break;
13711 ADA_OPERATORS;
13712#undef OP_DEFN
52ce6436
PH
13713
13714 case OP_AGGREGATE:
13715 *oplenp = 3;
13716 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13717 break;
13718
13719 case OP_CHOICES:
13720 *oplenp = 3;
13721 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13722 break;
4c4b4cd2
PH
13723 }
13724}
13725
c0201579
JK
13726/* Implementation of the exp_descriptor method operator_check. */
13727
13728static int
13729ada_operator_check (struct expression *exp, int pos,
13730 int (*objfile_func) (struct objfile *objfile, void *data),
13731 void *data)
13732{
13733 const union exp_element *const elts = exp->elts;
13734 struct type *type = NULL;
13735
13736 switch (elts[pos].opcode)
13737 {
13738 case UNOP_IN_RANGE:
13739 case UNOP_QUAL:
13740 type = elts[pos + 1].type;
13741 break;
13742
13743 default:
13744 return operator_check_standard (exp, pos, objfile_func, data);
13745 }
13746
13747 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13748
13749 if (type && TYPE_OBJFILE (type)
13750 && (*objfile_func) (TYPE_OBJFILE (type), data))
13751 return 1;
13752
13753 return 0;
13754}
13755
a121b7c1 13756static const char *
4c4b4cd2
PH
13757ada_op_name (enum exp_opcode opcode)
13758{
13759 switch (opcode)
13760 {
76a01679 13761 default:
4c4b4cd2 13762 return op_name_standard (opcode);
52ce6436 13763
4c4b4cd2
PH
13764#define OP_DEFN(op, len, args, binop) case op: return #op;
13765 ADA_OPERATORS;
13766#undef OP_DEFN
52ce6436
PH
13767
13768 case OP_AGGREGATE:
13769 return "OP_AGGREGATE";
13770 case OP_CHOICES:
13771 return "OP_CHOICES";
13772 case OP_NAME:
13773 return "OP_NAME";
4c4b4cd2
PH
13774 }
13775}
13776
13777/* As for operator_length, but assumes PC is pointing at the first
13778 element of the operator, and gives meaningful results only for the
52ce6436 13779 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13780
13781static void
76a01679
JB
13782ada_forward_operator_length (struct expression *exp, int pc,
13783 int *oplenp, int *argsp)
4c4b4cd2 13784{
76a01679 13785 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13786 {
13787 default:
13788 *oplenp = *argsp = 0;
13789 break;
52ce6436 13790
4c4b4cd2
PH
13791#define OP_DEFN(op, len, args, binop) \
13792 case op: *oplenp = len; *argsp = args; break;
13793 ADA_OPERATORS;
13794#undef OP_DEFN
52ce6436
PH
13795
13796 case OP_AGGREGATE:
13797 *oplenp = 3;
13798 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13799 break;
13800
13801 case OP_CHOICES:
13802 *oplenp = 3;
13803 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13804 break;
13805
13806 case OP_STRING:
13807 case OP_NAME:
13808 {
13809 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13810
52ce6436
PH
13811 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13812 *argsp = 0;
13813 break;
13814 }
4c4b4cd2
PH
13815 }
13816}
13817
13818static int
13819ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13820{
13821 enum exp_opcode op = exp->elts[elt].opcode;
13822 int oplen, nargs;
13823 int pc = elt;
13824 int i;
76a01679 13825
4c4b4cd2
PH
13826 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13827
76a01679 13828 switch (op)
4c4b4cd2 13829 {
76a01679 13830 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13831 case OP_ATR_FIRST:
13832 case OP_ATR_LAST:
13833 case OP_ATR_LENGTH:
13834 case OP_ATR_IMAGE:
13835 case OP_ATR_MAX:
13836 case OP_ATR_MIN:
13837 case OP_ATR_MODULUS:
13838 case OP_ATR_POS:
13839 case OP_ATR_SIZE:
13840 case OP_ATR_TAG:
13841 case OP_ATR_VAL:
13842 break;
13843
13844 case UNOP_IN_RANGE:
13845 case UNOP_QUAL:
323e0a4a
AC
13846 /* XXX: gdb_sprint_host_address, type_sprint */
13847 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13848 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13849 fprintf_filtered (stream, " (");
13850 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13851 fprintf_filtered (stream, ")");
13852 break;
13853 case BINOP_IN_BOUNDS:
52ce6436
PH
13854 fprintf_filtered (stream, " (%d)",
13855 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13856 break;
13857 case TERNOP_IN_RANGE:
13858 break;
13859
52ce6436
PH
13860 case OP_AGGREGATE:
13861 case OP_OTHERS:
13862 case OP_DISCRETE_RANGE:
13863 case OP_POSITIONAL:
13864 case OP_CHOICES:
13865 break;
13866
13867 case OP_NAME:
13868 case OP_STRING:
13869 {
13870 char *name = &exp->elts[elt + 2].string;
13871 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13872
52ce6436
PH
13873 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13874 break;
13875 }
13876
4c4b4cd2
PH
13877 default:
13878 return dump_subexp_body_standard (exp, stream, elt);
13879 }
13880
13881 elt += oplen;
13882 for (i = 0; i < nargs; i += 1)
13883 elt = dump_subexp (exp, stream, elt);
13884
13885 return elt;
13886}
13887
13888/* The Ada extension of print_subexp (q.v.). */
13889
76a01679
JB
13890static void
13891ada_print_subexp (struct expression *exp, int *pos,
13892 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13893{
52ce6436 13894 int oplen, nargs, i;
4c4b4cd2
PH
13895 int pc = *pos;
13896 enum exp_opcode op = exp->elts[pc].opcode;
13897
13898 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13899
52ce6436 13900 *pos += oplen;
4c4b4cd2
PH
13901 switch (op)
13902 {
13903 default:
52ce6436 13904 *pos -= oplen;
4c4b4cd2
PH
13905 print_subexp_standard (exp, pos, stream, prec);
13906 return;
13907
13908 case OP_VAR_VALUE:
4c4b4cd2
PH
13909 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13910 return;
13911
13912 case BINOP_IN_BOUNDS:
323e0a4a 13913 /* XXX: sprint_subexp */
4c4b4cd2 13914 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13915 fputs_filtered (" in ", stream);
4c4b4cd2 13916 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13917 fputs_filtered ("'range", stream);
4c4b4cd2 13918 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13919 fprintf_filtered (stream, "(%ld)",
13920 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13921 return;
13922
13923 case TERNOP_IN_RANGE:
4c4b4cd2 13924 if (prec >= PREC_EQUAL)
76a01679 13925 fputs_filtered ("(", stream);
323e0a4a 13926 /* XXX: sprint_subexp */
4c4b4cd2 13927 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13928 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13929 print_subexp (exp, pos, stream, PREC_EQUAL);
13930 fputs_filtered (" .. ", stream);
13931 print_subexp (exp, pos, stream, PREC_EQUAL);
13932 if (prec >= PREC_EQUAL)
76a01679
JB
13933 fputs_filtered (")", stream);
13934 return;
4c4b4cd2
PH
13935
13936 case OP_ATR_FIRST:
13937 case OP_ATR_LAST:
13938 case OP_ATR_LENGTH:
13939 case OP_ATR_IMAGE:
13940 case OP_ATR_MAX:
13941 case OP_ATR_MIN:
13942 case OP_ATR_MODULUS:
13943 case OP_ATR_POS:
13944 case OP_ATR_SIZE:
13945 case OP_ATR_TAG:
13946 case OP_ATR_VAL:
4c4b4cd2 13947 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13948 {
13949 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13950 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13951 &type_print_raw_options);
76a01679
JB
13952 *pos += 3;
13953 }
4c4b4cd2 13954 else
76a01679 13955 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13956 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13957 if (nargs > 1)
76a01679
JB
13958 {
13959 int tem;
5b4ee69b 13960
76a01679
JB
13961 for (tem = 1; tem < nargs; tem += 1)
13962 {
13963 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13964 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13965 }
13966 fputs_filtered (")", stream);
13967 }
4c4b4cd2 13968 return;
14f9c5c9 13969
4c4b4cd2 13970 case UNOP_QUAL:
4c4b4cd2
PH
13971 type_print (exp->elts[pc + 1].type, "", stream, 0);
13972 fputs_filtered ("'(", stream);
13973 print_subexp (exp, pos, stream, PREC_PREFIX);
13974 fputs_filtered (")", stream);
13975 return;
14f9c5c9 13976
4c4b4cd2 13977 case UNOP_IN_RANGE:
323e0a4a 13978 /* XXX: sprint_subexp */
4c4b4cd2 13979 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13980 fputs_filtered (" in ", stream);
79d43c61
TT
13981 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13982 &type_print_raw_options);
4c4b4cd2 13983 return;
52ce6436
PH
13984
13985 case OP_DISCRETE_RANGE:
13986 print_subexp (exp, pos, stream, PREC_SUFFIX);
13987 fputs_filtered ("..", stream);
13988 print_subexp (exp, pos, stream, PREC_SUFFIX);
13989 return;
13990
13991 case OP_OTHERS:
13992 fputs_filtered ("others => ", stream);
13993 print_subexp (exp, pos, stream, PREC_SUFFIX);
13994 return;
13995
13996 case OP_CHOICES:
13997 for (i = 0; i < nargs-1; i += 1)
13998 {
13999 if (i > 0)
14000 fputs_filtered ("|", stream);
14001 print_subexp (exp, pos, stream, PREC_SUFFIX);
14002 }
14003 fputs_filtered (" => ", stream);
14004 print_subexp (exp, pos, stream, PREC_SUFFIX);
14005 return;
14006
14007 case OP_POSITIONAL:
14008 print_subexp (exp, pos, stream, PREC_SUFFIX);
14009 return;
14010
14011 case OP_AGGREGATE:
14012 fputs_filtered ("(", stream);
14013 for (i = 0; i < nargs; i += 1)
14014 {
14015 if (i > 0)
14016 fputs_filtered (", ", stream);
14017 print_subexp (exp, pos, stream, PREC_SUFFIX);
14018 }
14019 fputs_filtered (")", stream);
14020 return;
4c4b4cd2
PH
14021 }
14022}
14f9c5c9
AS
14023
14024/* Table mapping opcodes into strings for printing operators
14025 and precedences of the operators. */
14026
d2e4a39e
AS
14027static const struct op_print ada_op_print_tab[] = {
14028 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14029 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14030 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14031 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14032 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14033 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14034 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14035 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14036 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14037 {">=", BINOP_GEQ, PREC_ORDER, 0},
14038 {">", BINOP_GTR, PREC_ORDER, 0},
14039 {"<", BINOP_LESS, PREC_ORDER, 0},
14040 {">>", BINOP_RSH, PREC_SHIFT, 0},
14041 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14042 {"+", BINOP_ADD, PREC_ADD, 0},
14043 {"-", BINOP_SUB, PREC_ADD, 0},
14044 {"&", BINOP_CONCAT, PREC_ADD, 0},
14045 {"*", BINOP_MUL, PREC_MUL, 0},
14046 {"/", BINOP_DIV, PREC_MUL, 0},
14047 {"rem", BINOP_REM, PREC_MUL, 0},
14048 {"mod", BINOP_MOD, PREC_MUL, 0},
14049 {"**", BINOP_EXP, PREC_REPEAT, 0},
14050 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14051 {"-", UNOP_NEG, PREC_PREFIX, 0},
14052 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14053 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14054 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14055 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
14056 {".all", UNOP_IND, PREC_SUFFIX, 1},
14057 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14058 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 14059 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
14060};
14061\f
72d5681a
PH
14062enum ada_primitive_types {
14063 ada_primitive_type_int,
14064 ada_primitive_type_long,
14065 ada_primitive_type_short,
14066 ada_primitive_type_char,
14067 ada_primitive_type_float,
14068 ada_primitive_type_double,
14069 ada_primitive_type_void,
14070 ada_primitive_type_long_long,
14071 ada_primitive_type_long_double,
14072 ada_primitive_type_natural,
14073 ada_primitive_type_positive,
14074 ada_primitive_type_system_address,
08f49010 14075 ada_primitive_type_storage_offset,
72d5681a
PH
14076 nr_ada_primitive_types
14077};
6c038f32
PH
14078
14079static void
d4a9a881 14080ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
14081 struct language_arch_info *lai)
14082{
d4a9a881 14083 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 14084
72d5681a 14085 lai->primitive_type_vector
d4a9a881 14086 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 14087 struct type *);
e9bb382b
UW
14088
14089 lai->primitive_type_vector [ada_primitive_type_int]
14090 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14091 0, "integer");
14092 lai->primitive_type_vector [ada_primitive_type_long]
14093 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14094 0, "long_integer");
14095 lai->primitive_type_vector [ada_primitive_type_short]
14096 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14097 0, "short_integer");
14098 lai->string_char_type
14099 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 14100 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
14101 lai->primitive_type_vector [ada_primitive_type_float]
14102 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 14103 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
14104 lai->primitive_type_vector [ada_primitive_type_double]
14105 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14106 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14107 lai->primitive_type_vector [ada_primitive_type_long_long]
14108 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14109 0, "long_long_integer");
14110 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14111 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14112 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14113 lai->primitive_type_vector [ada_primitive_type_natural]
14114 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14115 0, "natural");
14116 lai->primitive_type_vector [ada_primitive_type_positive]
14117 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14118 0, "positive");
14119 lai->primitive_type_vector [ada_primitive_type_void]
14120 = builtin->builtin_void;
14121
14122 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14123 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14124 "void"));
72d5681a
PH
14125 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14126 = "system__address";
fbb06eb1 14127
08f49010
XR
14128 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14129 type. This is a signed integral type whose size is the same as
14130 the size of addresses. */
14131 {
14132 unsigned int addr_length = TYPE_LENGTH
14133 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14134
14135 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14136 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14137 "storage_offset");
14138 }
14139
47e729a8 14140 lai->bool_type_symbol = NULL;
fbb06eb1 14141 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14142}
6c038f32
PH
14143\f
14144 /* Language vector */
14145
14146/* Not really used, but needed in the ada_language_defn. */
14147
14148static void
6c7a06a3 14149emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14150{
6c7a06a3 14151 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14152}
14153
14154static int
410a0ff2 14155parse (struct parser_state *ps)
6c038f32
PH
14156{
14157 warnings_issued = 0;
410a0ff2 14158 return ada_parse (ps);
6c038f32
PH
14159}
14160
14161static const struct exp_descriptor ada_exp_descriptor = {
14162 ada_print_subexp,
14163 ada_operator_length,
c0201579 14164 ada_operator_check,
6c038f32
PH
14165 ada_op_name,
14166 ada_dump_subexp_body,
14167 ada_evaluate_subexp
14168};
14169
b5ec771e
PA
14170/* symbol_name_matcher_ftype adapter for wild_match. */
14171
14172static bool
14173do_wild_match (const char *symbol_search_name,
14174 const lookup_name_info &lookup_name,
a207cff2 14175 completion_match_result *comp_match_res)
b5ec771e
PA
14176{
14177 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14178}
14179
14180/* symbol_name_matcher_ftype adapter for full_match. */
14181
14182static bool
14183do_full_match (const char *symbol_search_name,
14184 const lookup_name_info &lookup_name,
a207cff2 14185 completion_match_result *comp_match_res)
b5ec771e
PA
14186{
14187 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14188}
14189
a2cd4f14
JB
14190/* symbol_name_matcher_ftype for exact (verbatim) matches. */
14191
14192static bool
14193do_exact_match (const char *symbol_search_name,
14194 const lookup_name_info &lookup_name,
14195 completion_match_result *comp_match_res)
14196{
14197 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
14198}
14199
b5ec771e
PA
14200/* Build the Ada lookup name for LOOKUP_NAME. */
14201
14202ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14203{
14204 const std::string &user_name = lookup_name.name ();
14205
14206 if (user_name[0] == '<')
14207 {
14208 if (user_name.back () == '>')
14209 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14210 else
14211 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14212 m_encoded_p = true;
14213 m_verbatim_p = true;
14214 m_wild_match_p = false;
14215 m_standard_p = false;
14216 }
14217 else
14218 {
14219 m_verbatim_p = false;
14220
14221 m_encoded_p = user_name.find ("__") != std::string::npos;
14222
14223 if (!m_encoded_p)
14224 {
14225 const char *folded = ada_fold_name (user_name.c_str ());
14226 const char *encoded = ada_encode_1 (folded, false);
14227 if (encoded != NULL)
14228 m_encoded_name = encoded;
14229 else
14230 m_encoded_name = user_name;
14231 }
14232 else
14233 m_encoded_name = user_name;
14234
14235 /* Handle the 'package Standard' special case. See description
14236 of m_standard_p. */
14237 if (startswith (m_encoded_name.c_str (), "standard__"))
14238 {
14239 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14240 m_standard_p = true;
14241 }
14242 else
14243 m_standard_p = false;
74ccd7f5 14244
b5ec771e
PA
14245 /* If the name contains a ".", then the user is entering a fully
14246 qualified entity name, and the match must not be done in wild
14247 mode. Similarly, if the user wants to complete what looks
14248 like an encoded name, the match must not be done in wild
14249 mode. Also, in the standard__ special case always do
14250 non-wild matching. */
14251 m_wild_match_p
14252 = (lookup_name.match_type () != symbol_name_match_type::FULL
14253 && !m_encoded_p
14254 && !m_standard_p
14255 && user_name.find ('.') == std::string::npos);
14256 }
14257}
14258
14259/* symbol_name_matcher_ftype method for Ada. This only handles
14260 completion mode. */
14261
14262static bool
14263ada_symbol_name_matches (const char *symbol_search_name,
14264 const lookup_name_info &lookup_name,
a207cff2 14265 completion_match_result *comp_match_res)
74ccd7f5 14266{
b5ec771e
PA
14267 return lookup_name.ada ().matches (symbol_search_name,
14268 lookup_name.match_type (),
a207cff2 14269 comp_match_res);
b5ec771e
PA
14270}
14271
de63c46b
PA
14272/* A name matcher that matches the symbol name exactly, with
14273 strcmp. */
14274
14275static bool
14276literal_symbol_name_matcher (const char *symbol_search_name,
14277 const lookup_name_info &lookup_name,
14278 completion_match_result *comp_match_res)
14279{
14280 const std::string &name = lookup_name.name ();
14281
14282 int cmp = (lookup_name.completion_mode ()
14283 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14284 : strcmp (symbol_search_name, name.c_str ()));
14285 if (cmp == 0)
14286 {
14287 if (comp_match_res != NULL)
14288 comp_match_res->set_match (symbol_search_name);
14289 return true;
14290 }
14291 else
14292 return false;
14293}
14294
b5ec771e
PA
14295/* Implement the "la_get_symbol_name_matcher" language_defn method for
14296 Ada. */
14297
14298static symbol_name_matcher_ftype *
14299ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14300{
de63c46b
PA
14301 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14302 return literal_symbol_name_matcher;
14303
b5ec771e
PA
14304 if (lookup_name.completion_mode ())
14305 return ada_symbol_name_matches;
74ccd7f5 14306 else
b5ec771e
PA
14307 {
14308 if (lookup_name.ada ().wild_match_p ())
14309 return do_wild_match;
a2cd4f14
JB
14310 else if (lookup_name.ada ().verbatim_p ())
14311 return do_exact_match;
b5ec771e
PA
14312 else
14313 return do_full_match;
14314 }
74ccd7f5
JB
14315}
14316
a5ee536b
JB
14317/* Implement the "la_read_var_value" language_defn method for Ada. */
14318
14319static struct value *
63e43d3a
PMR
14320ada_read_var_value (struct symbol *var, const struct block *var_block,
14321 struct frame_info *frame)
a5ee536b 14322{
3977b71f 14323 const struct block *frame_block = NULL;
a5ee536b
JB
14324 struct symbol *renaming_sym = NULL;
14325
14326 /* The only case where default_read_var_value is not sufficient
14327 is when VAR is a renaming... */
14328 if (frame)
14329 frame_block = get_frame_block (frame, NULL);
14330 if (frame_block)
14331 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14332 if (renaming_sym != NULL)
14333 return ada_read_renaming_var_value (renaming_sym, frame_block);
14334
14335 /* This is a typical case where we expect the default_read_var_value
14336 function to work. */
63e43d3a 14337 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14338}
14339
56618e20
TT
14340static const char *ada_extensions[] =
14341{
14342 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14343};
14344
47e77640 14345extern const struct language_defn ada_language_defn = {
6c038f32 14346 "ada", /* Language name */
6abde28f 14347 "Ada",
6c038f32 14348 language_ada,
6c038f32 14349 range_check_off,
6c038f32
PH
14350 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14351 that's not quite what this means. */
6c038f32 14352 array_row_major,
9a044a89 14353 macro_expansion_no,
56618e20 14354 ada_extensions,
6c038f32
PH
14355 &ada_exp_descriptor,
14356 parse,
6c038f32
PH
14357 resolve,
14358 ada_printchar, /* Print a character constant */
14359 ada_printstr, /* Function to print string constant */
14360 emit_char, /* Function to print single char (not used) */
6c038f32 14361 ada_print_type, /* Print a type using appropriate syntax */
be942545 14362 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14363 ada_val_print, /* Print a value using appropriate syntax */
14364 ada_value_print, /* Print a top-level value */
a5ee536b 14365 ada_read_var_value, /* la_read_var_value */
6c038f32 14366 NULL, /* Language specific skip_trampoline */
2b2d9e11 14367 NULL, /* name_of_this */
59cc4834 14368 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14369 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14370 basic_lookup_transparent_type, /* lookup_transparent_type */
14371 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14372 ada_sniff_from_mangled_name,
0963b4bd
MS
14373 NULL, /* Language specific
14374 class_name_from_physname */
6c038f32
PH
14375 ada_op_print_tab, /* expression operators for printing */
14376 0, /* c-style arrays */
14377 1, /* String lower bound */
6c038f32 14378 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14379 ada_collect_symbol_completion_matches,
72d5681a 14380 ada_language_arch_info,
e79af960 14381 ada_print_array_index,
41f1b697 14382 default_pass_by_reference,
ae6a3a4c 14383 c_get_string,
e2b7af72 14384 ada_watch_location_expression,
b5ec771e 14385 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14386 ada_iterate_over_symbols,
5ffa0793 14387 default_search_name_hash,
a53b64ea 14388 &ada_varobj_ops,
bb2ec1b3
TT
14389 NULL,
14390 NULL,
6c038f32
PH
14391 LANG_MAGIC
14392};
14393
5bf03f13
JB
14394/* Command-list for the "set/show ada" prefix command. */
14395static struct cmd_list_element *set_ada_list;
14396static struct cmd_list_element *show_ada_list;
14397
14398/* Implement the "set ada" prefix command. */
14399
14400static void
981a3fb3 14401set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14402{
14403 printf_unfiltered (_(\
14404"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14405 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14406}
14407
14408/* Implement the "show ada" prefix command. */
14409
14410static void
981a3fb3 14411show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14412{
14413 cmd_show_list (show_ada_list, from_tty, "");
14414}
14415
2060206e
PA
14416static void
14417initialize_ada_catchpoint_ops (void)
14418{
14419 struct breakpoint_ops *ops;
14420
14421 initialize_breakpoint_ops ();
14422
14423 ops = &catch_exception_breakpoint_ops;
14424 *ops = bkpt_breakpoint_ops;
2060206e
PA
14425 ops->allocate_location = allocate_location_catch_exception;
14426 ops->re_set = re_set_catch_exception;
14427 ops->check_status = check_status_catch_exception;
14428 ops->print_it = print_it_catch_exception;
14429 ops->print_one = print_one_catch_exception;
14430 ops->print_mention = print_mention_catch_exception;
14431 ops->print_recreate = print_recreate_catch_exception;
14432
14433 ops = &catch_exception_unhandled_breakpoint_ops;
14434 *ops = bkpt_breakpoint_ops;
2060206e
PA
14435 ops->allocate_location = allocate_location_catch_exception_unhandled;
14436 ops->re_set = re_set_catch_exception_unhandled;
14437 ops->check_status = check_status_catch_exception_unhandled;
14438 ops->print_it = print_it_catch_exception_unhandled;
14439 ops->print_one = print_one_catch_exception_unhandled;
14440 ops->print_mention = print_mention_catch_exception_unhandled;
14441 ops->print_recreate = print_recreate_catch_exception_unhandled;
14442
14443 ops = &catch_assert_breakpoint_ops;
14444 *ops = bkpt_breakpoint_ops;
2060206e
PA
14445 ops->allocate_location = allocate_location_catch_assert;
14446 ops->re_set = re_set_catch_assert;
14447 ops->check_status = check_status_catch_assert;
14448 ops->print_it = print_it_catch_assert;
14449 ops->print_one = print_one_catch_assert;
14450 ops->print_mention = print_mention_catch_assert;
14451 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14452
14453 ops = &catch_handlers_breakpoint_ops;
14454 *ops = bkpt_breakpoint_ops;
14455 ops->allocate_location = allocate_location_catch_handlers;
14456 ops->re_set = re_set_catch_handlers;
14457 ops->check_status = check_status_catch_handlers;
14458 ops->print_it = print_it_catch_handlers;
14459 ops->print_one = print_one_catch_handlers;
14460 ops->print_mention = print_mention_catch_handlers;
14461 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14462}
14463
3d9434b5
JB
14464/* This module's 'new_objfile' observer. */
14465
14466static void
14467ada_new_objfile_observer (struct objfile *objfile)
14468{
14469 ada_clear_symbol_cache ();
14470}
14471
14472/* This module's 'free_objfile' observer. */
14473
14474static void
14475ada_free_objfile_observer (struct objfile *objfile)
14476{
14477 ada_clear_symbol_cache ();
14478}
14479
d2e4a39e 14480void
6c038f32 14481_initialize_ada_language (void)
14f9c5c9 14482{
2060206e
PA
14483 initialize_ada_catchpoint_ops ();
14484
5bf03f13 14485 add_prefix_cmd ("ada", no_class, set_ada_command,
470678d7 14486 _("Prefix command for changing Ada-specific settings"),
5bf03f13
JB
14487 &set_ada_list, "set ada ", 0, &setlist);
14488
14489 add_prefix_cmd ("ada", no_class, show_ada_command,
14490 _("Generic command for showing Ada-specific settings."),
14491 &show_ada_list, "show ada ", 0, &showlist);
14492
14493 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14494 &trust_pad_over_xvs, _("\
14495Enable or disable an optimization trusting PAD types over XVS types"), _("\
14496Show whether an optimization trusting PAD types over XVS types is activated"),
14497 _("\
14498This is related to the encoding used by the GNAT compiler. The debugger\n\
14499should normally trust the contents of PAD types, but certain older versions\n\
14500of GNAT have a bug that sometimes causes the information in the PAD type\n\
14501to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14502work around this bug. It is always safe to turn this option \"off\", but\n\
14503this incurs a slight performance penalty, so it is recommended to NOT change\n\
14504this option to \"off\" unless necessary."),
14505 NULL, NULL, &set_ada_list, &show_ada_list);
14506
d72413e6
PMR
14507 add_setshow_boolean_cmd ("print-signatures", class_vars,
14508 &print_signatures, _("\
14509Enable or disable the output of formal and return types for functions in the \
14510overloads selection menu"), _("\
14511Show whether the output of formal and return types for functions in the \
14512overloads selection menu is activated"),
14513 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14514
9ac4176b
PA
14515 add_catch_command ("exception", _("\
14516Catch Ada exceptions, when raised.\n\
60a90376
JB
14517Usage: catch exception [ ARG ]\n\
14518\n\
14519Without any argument, stop when any Ada exception is raised.\n\
14520If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14521being raised does not have a handler (and will therefore lead to the task's\n\
14522termination).\n\
14523Otherwise, the catchpoint only stops when the name of the exception being\n\
14524raised is the same as ARG."),
9ac4176b
PA
14525 catch_ada_exception_command,
14526 NULL,
14527 CATCH_PERMANENT,
14528 CATCH_TEMPORARY);
9f757bf7
XR
14529
14530 add_catch_command ("handlers", _("\
14531Catch Ada exceptions, when handled.\n\
14532With an argument, catch only exceptions with the given name."),
14533 catch_ada_handlers_command,
14534 NULL,
14535 CATCH_PERMANENT,
14536 CATCH_TEMPORARY);
9ac4176b
PA
14537 add_catch_command ("assert", _("\
14538Catch failed Ada assertions, when raised.\n\
14539With an argument, catch only exceptions with the given name."),
14540 catch_assert_command,
14541 NULL,
14542 CATCH_PERMANENT,
14543 CATCH_TEMPORARY);
14544
6c038f32 14545 varsize_limit = 65536;
3fcded8f
JB
14546 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14547 &varsize_limit, _("\
14548Set the maximum number of bytes allowed in a variable-size object."), _("\
14549Show the maximum number of bytes allowed in a variable-size object."), _("\
14550Attempts to access an object whose size is not a compile-time constant\n\
14551and exceeds this limit will cause an error."),
14552 NULL, NULL, &setlist, &showlist);
6c038f32 14553
778865d3
JB
14554 add_info ("exceptions", info_exceptions_command,
14555 _("\
14556List all Ada exception names.\n\
14557If a regular expression is passed as an argument, only those matching\n\
14558the regular expression are listed."));
14559
c6044dd1
JB
14560 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14561 _("Set Ada maintenance-related variables."),
14562 &maint_set_ada_cmdlist, "maintenance set ada ",
14563 0/*allow-unknown*/, &maintenance_set_cmdlist);
14564
14565 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14566 _("Show Ada maintenance-related variables"),
14567 &maint_show_ada_cmdlist, "maintenance show ada ",
14568 0/*allow-unknown*/, &maintenance_show_cmdlist);
14569
14570 add_setshow_boolean_cmd
14571 ("ignore-descriptive-types", class_maintenance,
14572 &ada_ignore_descriptive_types_p,
14573 _("Set whether descriptive types generated by GNAT should be ignored."),
14574 _("Show whether descriptive types generated by GNAT should be ignored."),
14575 _("\
14576When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14577DWARF attribute."),
14578 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14579
459a2e4c
TT
14580 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14581 NULL, xcalloc, xfree);
6b69afc4 14582
3d9434b5 14583 /* The ada-lang observers. */
76727919
TT
14584 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14585 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14586 gdb::observers::inferior_exit.attach (ada_inferior_exit);
ee01b665
JB
14587
14588 /* Setup various context-specific data. */
e802dbe0 14589 ada_inferior_data
8e260fc0 14590 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14591 ada_pspace_data_handle
14592 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14593}