]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Remove newlines from warnings
[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>
2ff0a947 66#include <map>
ccefe4c4 67
4c4b4cd2 68/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 69 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
70 Copied from valarith.c. */
71
72#ifndef TRUNCATION_TOWARDS_ZERO
73#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
74#endif
75
d2e4a39e 76static struct type *desc_base_type (struct type *);
14f9c5c9 77
d2e4a39e 78static struct type *desc_bounds_type (struct type *);
14f9c5c9 79
d2e4a39e 80static struct value *desc_bounds (struct value *);
14f9c5c9 81
d2e4a39e 82static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 83
d2e4a39e 84static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 85
556bdfd4 86static struct type *desc_data_target_type (struct type *);
14f9c5c9 87
d2e4a39e 88static struct value *desc_data (struct value *);
14f9c5c9 89
d2e4a39e 90static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 91
d2e4a39e 92static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 93
d2e4a39e 94static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 95
d2e4a39e 96static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 97
d2e4a39e 98static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 99
d2e4a39e 100static struct type *desc_index_type (struct type *, int);
14f9c5c9 101
d2e4a39e 102static int desc_arity (struct type *);
14f9c5c9 103
d2e4a39e 104static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 105
d2e4a39e 106static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 107
40bc484c 108static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 109
4c4b4cd2 110static void ada_add_block_symbols (struct obstack *,
b5ec771e
PA
111 const struct block *,
112 const lookup_name_info &lookup_name,
113 domain_enum, struct objfile *);
14f9c5c9 114
22cee43f 115static void ada_add_all_symbols (struct obstack *, const struct block *,
b5ec771e
PA
116 const lookup_name_info &lookup_name,
117 domain_enum, int, int *);
22cee43f 118
d12307c1 119static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 120
76a01679 121static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 122 const struct block *);
14f9c5c9 123
4c4b4cd2
PH
124static int num_defns_collected (struct obstack *);
125
d12307c1 126static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 127
e9d9f57e 128static struct value *resolve_subexp (expression_up *, int *, int,
699bd4cf
TT
129 struct type *, int,
130 innermost_block_tracker *);
14f9c5c9 131
e9d9f57e 132static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 133 struct symbol *, const struct block *);
14f9c5c9 134
d2e4a39e 135static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 136
a121b7c1 137static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
138
139static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 140
d2e4a39e 141static int numeric_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int integer_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int scalar_type_p (struct type *);
14f9c5c9 146
d2e4a39e 147static int discrete_type_p (struct type *);
14f9c5c9 148
a121b7c1 149static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 150 int, int);
4c4b4cd2 151
d2e4a39e 152static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 153
b4ba55a1
JB
154static struct type *ada_find_parallel_type_with_name (struct type *,
155 const char *);
156
d2e4a39e 157static int is_dynamic_field (struct type *, int);
14f9c5c9 158
10a2c479 159static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 160 const gdb_byte *,
4c4b4cd2
PH
161 CORE_ADDR, struct value *);
162
163static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 164
28c85d6c 165static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 166
d2e4a39e 167static struct type *to_static_fixed_type (struct type *);
f192137b 168static struct type *static_unwrap_type (struct type *type);
14f9c5c9 169
d2e4a39e 170static struct value *unwrap_value (struct value *);
14f9c5c9 171
ad82864c 172static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 173
ad82864c 174static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 175
ad82864c
JB
176static long decode_packed_array_bitsize (struct type *);
177
178static struct value *decode_constrained_packed_array (struct value *);
179
180static int ada_is_packed_array_type (struct type *);
181
182static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 183
d2e4a39e 184static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 185 struct value **);
14f9c5c9 186
4c4b4cd2
PH
187static struct value *coerce_unspec_val_to_type (struct value *,
188 struct type *);
14f9c5c9 189
d2e4a39e 190static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 191
d2e4a39e 192static int equiv_types (struct type *, struct type *);
14f9c5c9 193
d2e4a39e 194static int is_name_suffix (const char *);
14f9c5c9 195
73589123
PH
196static int advance_wild_match (const char **, const char *, int);
197
b5ec771e 198static bool wild_match (const char *name, const char *patn);
14f9c5c9 199
d2e4a39e 200static struct value *ada_coerce_ref (struct value *);
14f9c5c9 201
4c4b4cd2
PH
202static LONGEST pos_atr (struct value *);
203
3cb382c9 204static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 205
d2e4a39e 206static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 207
4c4b4cd2
PH
208static struct symbol *standard_lookup (const char *, const struct block *,
209 domain_enum);
14f9c5c9 210
108d56a4 211static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
212 struct type *);
213
214static struct value *ada_value_primitive_field (struct value *, int, int,
215 struct type *);
216
0d5cff50 217static int find_struct_field (const char *, struct type *, int,
52ce6436 218 struct type **, int *, int *, int *, int *);
4c4b4cd2 219
d12307c1 220static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2 221 struct value **, int, const char *,
2a612529 222 struct type *, int);
4c4b4cd2 223
4c4b4cd2
PH
224static int ada_is_direct_array_type (struct type *);
225
72d5681a
PH
226static void ada_language_arch_info (struct gdbarch *,
227 struct language_arch_info *);
714e53ab 228
52ce6436
PH
229static struct value *ada_index_struct_field (int, struct value *, int,
230 struct type *);
231
232static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
233 struct expression *,
234 int *, enum noside);
52ce6436
PH
235
236static void aggregate_assign_from_choices (struct value *, struct value *,
237 struct expression *,
238 int *, LONGEST *, int *,
239 int, LONGEST, LONGEST);
240
241static void aggregate_assign_positional (struct value *, struct value *,
242 struct expression *,
243 int *, LONGEST *, int *, int,
244 LONGEST, LONGEST);
245
246
247static void aggregate_assign_others (struct value *, struct value *,
248 struct expression *,
249 int *, LONGEST *, int, LONGEST, LONGEST);
250
251
252static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
253
254
255static struct value *ada_evaluate_subexp (struct type *, struct expression *,
256 int *, enum noside);
257
258static void ada_forward_operator_length (struct expression *, int, int *,
259 int *);
852dff6c
JB
260
261static struct type *ada_find_any_type (const char *name);
b5ec771e
PA
262
263static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
264 (const lookup_name_info &lookup_name);
265
4c4b4cd2
PH
266\f
267
ee01b665
JB
268/* The result of a symbol lookup to be stored in our symbol cache. */
269
270struct cache_entry
271{
272 /* The name used to perform the lookup. */
273 const char *name;
274 /* The namespace used during the lookup. */
fe978cb0 275 domain_enum domain;
ee01b665
JB
276 /* The symbol returned by the lookup, or NULL if no matching symbol
277 was found. */
278 struct symbol *sym;
279 /* The block where the symbol was found, or NULL if no matching
280 symbol was found. */
281 const struct block *block;
282 /* A pointer to the next entry with the same hash. */
283 struct cache_entry *next;
284};
285
286/* The Ada symbol cache, used to store the result of Ada-mode symbol
287 lookups in the course of executing the user's commands.
288
289 The cache is implemented using a simple, fixed-sized hash.
290 The size is fixed on the grounds that there are not likely to be
291 all that many symbols looked up during any given session, regardless
292 of the size of the symbol table. If we decide to go to a resizable
293 table, let's just use the stuff from libiberty instead. */
294
295#define HASH_SIZE 1009
296
297struct ada_symbol_cache
298{
299 /* An obstack used to store the entries in our cache. */
300 struct obstack cache_space;
301
302 /* The root of the hash table used to implement our symbol cache. */
303 struct cache_entry *root[HASH_SIZE];
304};
305
306static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 307
4c4b4cd2 308/* Maximum-sized dynamic type. */
14f9c5c9
AS
309static unsigned int varsize_limit;
310
67cb5b2d 311static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
312#ifdef VMS
313 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
314#else
14f9c5c9 315 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 316#endif
14f9c5c9 317
4c4b4cd2 318/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 319static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 320 = "__gnat_ada_main_program_name";
14f9c5c9 321
4c4b4cd2
PH
322/* Limit on the number of warnings to raise per expression evaluation. */
323static int warning_limit = 2;
324
325/* Number of warning messages issued; reset to 0 by cleanups after
326 expression evaluation. */
327static int warnings_issued = 0;
328
329static const char *known_runtime_file_name_patterns[] = {
330 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
331};
332
333static const char *known_auxiliary_function_name_patterns[] = {
334 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
335};
336
c6044dd1
JB
337/* Maintenance-related settings for this module. */
338
339static struct cmd_list_element *maint_set_ada_cmdlist;
340static struct cmd_list_element *maint_show_ada_cmdlist;
341
342/* Implement the "maintenance set ada" (prefix) command. */
343
344static void
981a3fb3 345maint_set_ada_cmd (const char *args, int from_tty)
c6044dd1 346{
635c7e8a
TT
347 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
348 gdb_stdout);
c6044dd1
JB
349}
350
351/* Implement the "maintenance show ada" (prefix) command. */
352
353static void
981a3fb3 354maint_show_ada_cmd (const char *args, int from_tty)
c6044dd1
JB
355{
356 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
357}
358
359/* The "maintenance ada set/show ignore-descriptive-type" value. */
360
361static int ada_ignore_descriptive_types_p = 0;
362
e802dbe0
JB
363 /* Inferior-specific data. */
364
365/* Per-inferior data for this module. */
366
367struct ada_inferior_data
368{
369 /* The ada__tags__type_specific_data type, which is used when decoding
370 tagged types. With older versions of GNAT, this type was directly
371 accessible through a component ("tsd") in the object tag. But this
372 is no longer the case, so we cache it for each inferior. */
f37b313d 373 struct type *tsd_type = nullptr;
3eecfa55
JB
374
375 /* The exception_support_info data. This data is used to determine
376 how to implement support for Ada exception catchpoints in a given
377 inferior. */
f37b313d 378 const struct exception_support_info *exception_info = nullptr;
e802dbe0
JB
379};
380
381/* Our key to this module's inferior data. */
f37b313d 382static const struct inferior_key<ada_inferior_data> ada_inferior_data;
e802dbe0
JB
383
384/* Return our inferior data for the given inferior (INF).
385
386 This function always returns a valid pointer to an allocated
387 ada_inferior_data structure. If INF's inferior data has not
388 been previously set, this functions creates a new one with all
389 fields set to zero, sets INF's inferior to it, and then returns
390 a pointer to that newly allocated ada_inferior_data. */
391
392static struct ada_inferior_data *
393get_ada_inferior_data (struct inferior *inf)
394{
395 struct ada_inferior_data *data;
396
f37b313d 397 data = ada_inferior_data.get (inf);
e802dbe0 398 if (data == NULL)
f37b313d 399 data = ada_inferior_data.emplace (inf);
e802dbe0
JB
400
401 return data;
402}
403
404/* Perform all necessary cleanups regarding our module's inferior data
405 that is required after the inferior INF just exited. */
406
407static void
408ada_inferior_exit (struct inferior *inf)
409{
f37b313d 410 ada_inferior_data.clear (inf);
e802dbe0
JB
411}
412
ee01b665
JB
413
414 /* program-space-specific data. */
415
416/* This module's per-program-space data. */
417struct ada_pspace_data
418{
f37b313d
TT
419 ~ada_pspace_data ()
420 {
421 if (sym_cache != NULL)
422 ada_free_symbol_cache (sym_cache);
423 }
424
ee01b665 425 /* The Ada symbol cache. */
f37b313d 426 struct ada_symbol_cache *sym_cache = nullptr;
ee01b665
JB
427};
428
429/* Key to our per-program-space data. */
f37b313d 430static const struct program_space_key<ada_pspace_data> ada_pspace_data_handle;
ee01b665
JB
431
432/* Return this module's data for the given program space (PSPACE).
433 If not is found, add a zero'ed one now.
434
435 This function always returns a valid object. */
436
437static struct ada_pspace_data *
438get_ada_pspace_data (struct program_space *pspace)
439{
440 struct ada_pspace_data *data;
441
f37b313d 442 data = ada_pspace_data_handle.get (pspace);
ee01b665 443 if (data == NULL)
f37b313d 444 data = ada_pspace_data_handle.emplace (pspace);
ee01b665
JB
445
446 return data;
447}
448
4c4b4cd2
PH
449 /* Utilities */
450
720d1a40 451/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 452 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
453
454 Normally, we really expect a typedef type to only have 1 typedef layer.
455 In other words, we really expect the target type of a typedef type to be
456 a non-typedef type. This is particularly true for Ada units, because
457 the language does not have a typedef vs not-typedef distinction.
458 In that respect, the Ada compiler has been trying to eliminate as many
459 typedef definitions in the debugging information, since they generally
460 do not bring any extra information (we still use typedef under certain
461 circumstances related mostly to the GNAT encoding).
462
463 Unfortunately, we have seen situations where the debugging information
464 generated by the compiler leads to such multiple typedef layers. For
465 instance, consider the following example with stabs:
466
467 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
468 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
469
470 This is an error in the debugging information which causes type
471 pck__float_array___XUP to be defined twice, and the second time,
472 it is defined as a typedef of a typedef.
473
474 This is on the fringe of legality as far as debugging information is
475 concerned, and certainly unexpected. But it is easy to handle these
476 situations correctly, so we can afford to be lenient in this case. */
477
478static struct type *
479ada_typedef_target_type (struct type *type)
480{
481 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
482 type = TYPE_TARGET_TYPE (type);
483 return type;
484}
485
41d27058
JB
486/* Given DECODED_NAME a string holding a symbol name in its
487 decoded form (ie using the Ada dotted notation), returns
488 its unqualified name. */
489
490static const char *
491ada_unqualified_name (const char *decoded_name)
492{
2b0f535a
JB
493 const char *result;
494
495 /* If the decoded name starts with '<', it means that the encoded
496 name does not follow standard naming conventions, and thus that
497 it is not your typical Ada symbol name. Trying to unqualify it
498 is therefore pointless and possibly erroneous. */
499 if (decoded_name[0] == '<')
500 return decoded_name;
501
502 result = strrchr (decoded_name, '.');
41d27058
JB
503 if (result != NULL)
504 result++; /* Skip the dot... */
505 else
506 result = decoded_name;
507
508 return result;
509}
510
39e7af3e 511/* Return a string starting with '<', followed by STR, and '>'. */
41d27058 512
39e7af3e 513static std::string
41d27058
JB
514add_angle_brackets (const char *str)
515{
39e7af3e 516 return string_printf ("<%s>", str);
41d27058 517}
96d887e8 518
67cb5b2d 519static const char *
4c4b4cd2
PH
520ada_get_gdb_completer_word_break_characters (void)
521{
522 return ada_completer_word_break_characters;
523}
524
e79af960
JB
525/* Print an array element index using the Ada syntax. */
526
527static void
528ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 529 const struct value_print_options *options)
e79af960 530{
79a45b7d 531 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
532 fprintf_filtered (stream, " => ");
533}
534
e2b7af72
JB
535/* la_watch_location_expression for Ada. */
536
537gdb::unique_xmalloc_ptr<char>
538ada_watch_location_expression (struct type *type, CORE_ADDR addr)
539{
540 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
541 std::string name = type_to_string (type);
542 return gdb::unique_xmalloc_ptr<char>
543 (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
544}
545
f27cf670 546/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 547 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 548 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 549
f27cf670
AS
550void *
551grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 552{
d2e4a39e
AS
553 if (*size < min_size)
554 {
555 *size *= 2;
556 if (*size < min_size)
4c4b4cd2 557 *size = min_size;
f27cf670 558 vect = xrealloc (vect, *size * element_size);
d2e4a39e 559 }
f27cf670 560 return vect;
14f9c5c9
AS
561}
562
563/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 564 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
565
566static int
ebf56fd3 567field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
568{
569 int len = strlen (target);
5b4ee69b 570
d2e4a39e 571 return
4c4b4cd2
PH
572 (strncmp (field_name, target, len) == 0
573 && (field_name[len] == '\0'
61012eef 574 || (startswith (field_name + len, "___")
76a01679
JB
575 && strcmp (field_name + strlen (field_name) - 6,
576 "___XVN") != 0)));
14f9c5c9
AS
577}
578
579
872c8b51
JB
580/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
581 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
582 and return its index. This function also handles fields whose name
583 have ___ suffixes because the compiler sometimes alters their name
584 by adding such a suffix to represent fields with certain constraints.
585 If the field could not be found, return a negative number if
586 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
587
588int
589ada_get_field_index (const struct type *type, const char *field_name,
590 int maybe_missing)
591{
592 int fieldno;
872c8b51
JB
593 struct type *struct_type = check_typedef ((struct type *) type);
594
595 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
596 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
597 return fieldno;
598
599 if (!maybe_missing)
323e0a4a 600 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 601 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
602
603 return -1;
604}
605
606/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
607
608int
d2e4a39e 609ada_name_prefix_len (const char *name)
14f9c5c9
AS
610{
611 if (name == NULL)
612 return 0;
d2e4a39e 613 else
14f9c5c9 614 {
d2e4a39e 615 const char *p = strstr (name, "___");
5b4ee69b 616
14f9c5c9 617 if (p == NULL)
4c4b4cd2 618 return strlen (name);
14f9c5c9 619 else
4c4b4cd2 620 return p - name;
14f9c5c9
AS
621 }
622}
623
4c4b4cd2
PH
624/* Return non-zero if SUFFIX is a suffix of STR.
625 Return zero if STR is null. */
626
14f9c5c9 627static int
d2e4a39e 628is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
629{
630 int len1, len2;
5b4ee69b 631
14f9c5c9
AS
632 if (str == NULL)
633 return 0;
634 len1 = strlen (str);
635 len2 = strlen (suffix);
4c4b4cd2 636 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
637}
638
4c4b4cd2
PH
639/* The contents of value VAL, treated as a value of type TYPE. The
640 result is an lval in memory if VAL is. */
14f9c5c9 641
d2e4a39e 642static struct value *
4c4b4cd2 643coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 644{
61ee279c 645 type = ada_check_typedef (type);
df407dfe 646 if (value_type (val) == type)
4c4b4cd2 647 return val;
d2e4a39e 648 else
14f9c5c9 649 {
4c4b4cd2
PH
650 struct value *result;
651
652 /* Make sure that the object size is not unreasonable before
653 trying to allocate some memory for it. */
c1b5a1a6 654 ada_ensure_varsize_limit (type);
4c4b4cd2 655
41e8491f
JK
656 if (value_lazy (val)
657 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
658 result = allocate_value_lazy (type);
659 else
660 {
661 result = allocate_value (type);
9a0dc9e3 662 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 663 }
74bcbdf3 664 set_value_component_location (result, val);
9bbda503
AC
665 set_value_bitsize (result, value_bitsize (val));
666 set_value_bitpos (result, value_bitpos (val));
c408a94f
TT
667 if (VALUE_LVAL (result) == lval_memory)
668 set_value_address (result, value_address (val));
14f9c5c9
AS
669 return result;
670 }
671}
672
fc1a4b47
AC
673static const gdb_byte *
674cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
675{
676 if (valaddr == NULL)
677 return NULL;
678 else
679 return valaddr + offset;
680}
681
682static CORE_ADDR
ebf56fd3 683cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
684{
685 if (address == 0)
686 return 0;
d2e4a39e 687 else
14f9c5c9
AS
688 return address + offset;
689}
690
4c4b4cd2
PH
691/* Issue a warning (as for the definition of warning in utils.c, but
692 with exactly one argument rather than ...), unless the limit on the
693 number of warnings has passed during the evaluation of the current
694 expression. */
a2249542 695
77109804
AC
696/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
697 provided by "complaint". */
a0b31db1 698static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 699
14f9c5c9 700static void
a2249542 701lim_warning (const char *format, ...)
14f9c5c9 702{
a2249542 703 va_list args;
a2249542 704
5b4ee69b 705 va_start (args, format);
4c4b4cd2
PH
706 warnings_issued += 1;
707 if (warnings_issued <= warning_limit)
a2249542
MK
708 vwarning (format, args);
709
710 va_end (args);
4c4b4cd2
PH
711}
712
714e53ab
PH
713/* Issue an error if the size of an object of type T is unreasonable,
714 i.e. if it would be a bad idea to allocate a value of this type in
715 GDB. */
716
c1b5a1a6
JB
717void
718ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
719{
720 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 721 error (_("object size is larger than varsize-limit"));
714e53ab
PH
722}
723
0963b4bd 724/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 725static LONGEST
c3e5cd34 726max_of_size (int size)
4c4b4cd2 727{
76a01679 728 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 729
76a01679 730 return top_bit | (top_bit - 1);
4c4b4cd2
PH
731}
732
0963b4bd 733/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 734static LONGEST
c3e5cd34 735min_of_size (int size)
4c4b4cd2 736{
c3e5cd34 737 return -max_of_size (size) - 1;
4c4b4cd2
PH
738}
739
0963b4bd 740/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 741static ULONGEST
c3e5cd34 742umax_of_size (int size)
4c4b4cd2 743{
76a01679 744 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 745
76a01679 746 return top_bit | (top_bit - 1);
4c4b4cd2
PH
747}
748
0963b4bd 749/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
750static LONGEST
751max_of_type (struct type *t)
4c4b4cd2 752{
c3e5cd34
PH
753 if (TYPE_UNSIGNED (t))
754 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
755 else
756 return max_of_size (TYPE_LENGTH (t));
757}
758
0963b4bd 759/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
760static LONGEST
761min_of_type (struct type *t)
762{
763 if (TYPE_UNSIGNED (t))
764 return 0;
765 else
766 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
767}
768
769/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
770LONGEST
771ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 772{
c3345124 773 type = resolve_dynamic_type (type, NULL, 0);
76a01679 774 switch (TYPE_CODE (type))
4c4b4cd2
PH
775 {
776 case TYPE_CODE_RANGE:
690cc4eb 777 return TYPE_HIGH_BOUND (type);
4c4b4cd2 778 case TYPE_CODE_ENUM:
14e75d8e 779 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
780 case TYPE_CODE_BOOL:
781 return 1;
782 case TYPE_CODE_CHAR:
76a01679 783 case TYPE_CODE_INT:
690cc4eb 784 return max_of_type (type);
4c4b4cd2 785 default:
43bbcdc2 786 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
787 }
788}
789
14e75d8e 790/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
791LONGEST
792ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 793{
c3345124 794 type = resolve_dynamic_type (type, NULL, 0);
76a01679 795 switch (TYPE_CODE (type))
4c4b4cd2
PH
796 {
797 case TYPE_CODE_RANGE:
690cc4eb 798 return TYPE_LOW_BOUND (type);
4c4b4cd2 799 case TYPE_CODE_ENUM:
14e75d8e 800 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
801 case TYPE_CODE_BOOL:
802 return 0;
803 case TYPE_CODE_CHAR:
76a01679 804 case TYPE_CODE_INT:
690cc4eb 805 return min_of_type (type);
4c4b4cd2 806 default:
43bbcdc2 807 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
808 }
809}
810
811/* The identity on non-range types. For range types, the underlying
76a01679 812 non-range scalar type. */
4c4b4cd2
PH
813
814static struct type *
18af8284 815get_base_type (struct type *type)
4c4b4cd2
PH
816{
817 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
818 {
76a01679
JB
819 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
820 return type;
4c4b4cd2
PH
821 type = TYPE_TARGET_TYPE (type);
822 }
823 return type;
14f9c5c9 824}
41246937
JB
825
826/* Return a decoded version of the given VALUE. This means returning
827 a value whose type is obtained by applying all the GNAT-specific
828 encondings, making the resulting type a static but standard description
829 of the initial type. */
830
831struct value *
832ada_get_decoded_value (struct value *value)
833{
834 struct type *type = ada_check_typedef (value_type (value));
835
836 if (ada_is_array_descriptor_type (type)
837 || (ada_is_constrained_packed_array_type (type)
838 && TYPE_CODE (type) != TYPE_CODE_PTR))
839 {
840 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
841 value = ada_coerce_to_simple_array_ptr (value);
842 else
843 value = ada_coerce_to_simple_array (value);
844 }
845 else
846 value = ada_to_fixed_value (value);
847
848 return value;
849}
850
851/* Same as ada_get_decoded_value, but with the given TYPE.
852 Because there is no associated actual value for this type,
853 the resulting type might be a best-effort approximation in
854 the case of dynamic types. */
855
856struct type *
857ada_get_decoded_type (struct type *type)
858{
859 type = to_static_fixed_type (type);
860 if (ada_is_constrained_packed_array_type (type))
861 type = ada_coerce_to_simple_array_type (type);
862 return type;
863}
864
4c4b4cd2 865\f
76a01679 866
4c4b4cd2 867 /* Language Selection */
14f9c5c9
AS
868
869/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 870 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 871
14f9c5c9 872enum language
ccefe4c4 873ada_update_initial_language (enum language lang)
14f9c5c9 874{
d2e4a39e 875 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 876 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 877 return language_ada;
14f9c5c9
AS
878
879 return lang;
880}
96d887e8
PH
881
882/* If the main procedure is written in Ada, then return its name.
883 The result is good until the next call. Return NULL if the main
884 procedure doesn't appear to be in Ada. */
885
886char *
887ada_main_name (void)
888{
3b7344d5 889 struct bound_minimal_symbol msym;
e83e4e24 890 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 891
96d887e8
PH
892 /* For Ada, the name of the main procedure is stored in a specific
893 string constant, generated by the binder. Look for that symbol,
894 extract its address, and then read that string. If we didn't find
895 that string, then most probably the main procedure is not written
896 in Ada. */
897 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
898
3b7344d5 899 if (msym.minsym != NULL)
96d887e8 900 {
f9bc20b9
JB
901 CORE_ADDR main_program_name_addr;
902 int err_code;
903
77e371c0 904 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 905 if (main_program_name_addr == 0)
323e0a4a 906 error (_("Invalid address for Ada main program name."));
96d887e8 907
f9bc20b9
JB
908 target_read_string (main_program_name_addr, &main_program_name,
909 1024, &err_code);
910
911 if (err_code != 0)
912 return NULL;
e83e4e24 913 return main_program_name.get ();
96d887e8
PH
914 }
915
916 /* The main procedure doesn't seem to be in Ada. */
917 return NULL;
918}
14f9c5c9 919\f
4c4b4cd2 920 /* Symbols */
d2e4a39e 921
4c4b4cd2
PH
922/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
923 of NULLs. */
14f9c5c9 924
d2e4a39e
AS
925const struct ada_opname_map ada_opname_table[] = {
926 {"Oadd", "\"+\"", BINOP_ADD},
927 {"Osubtract", "\"-\"", BINOP_SUB},
928 {"Omultiply", "\"*\"", BINOP_MUL},
929 {"Odivide", "\"/\"", BINOP_DIV},
930 {"Omod", "\"mod\"", BINOP_MOD},
931 {"Orem", "\"rem\"", BINOP_REM},
932 {"Oexpon", "\"**\"", BINOP_EXP},
933 {"Olt", "\"<\"", BINOP_LESS},
934 {"Ole", "\"<=\"", BINOP_LEQ},
935 {"Ogt", "\">\"", BINOP_GTR},
936 {"Oge", "\">=\"", BINOP_GEQ},
937 {"Oeq", "\"=\"", BINOP_EQUAL},
938 {"One", "\"/=\"", BINOP_NOTEQUAL},
939 {"Oand", "\"and\"", BINOP_BITWISE_AND},
940 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
941 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
942 {"Oconcat", "\"&\"", BINOP_CONCAT},
943 {"Oabs", "\"abs\"", UNOP_ABS},
944 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
945 {"Oadd", "\"+\"", UNOP_PLUS},
946 {"Osubtract", "\"-\"", UNOP_NEG},
947 {NULL, NULL}
14f9c5c9
AS
948};
949
b5ec771e
PA
950/* The "encoded" form of DECODED, according to GNAT conventions. The
951 result is valid until the next call to ada_encode. If
952 THROW_ERRORS, throw an error if invalid operator name is found.
953 Otherwise, return NULL in that case. */
4c4b4cd2 954
b5ec771e
PA
955static char *
956ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 957{
4c4b4cd2
PH
958 static char *encoding_buffer = NULL;
959 static size_t encoding_buffer_size = 0;
d2e4a39e 960 const char *p;
14f9c5c9 961 int k;
d2e4a39e 962
4c4b4cd2 963 if (decoded == NULL)
14f9c5c9
AS
964 return NULL;
965
4c4b4cd2
PH
966 GROW_VECT (encoding_buffer, encoding_buffer_size,
967 2 * strlen (decoded) + 10);
14f9c5c9
AS
968
969 k = 0;
4c4b4cd2 970 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 971 {
cdc7bb92 972 if (*p == '.')
4c4b4cd2
PH
973 {
974 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
975 k += 2;
976 }
14f9c5c9 977 else if (*p == '"')
4c4b4cd2
PH
978 {
979 const struct ada_opname_map *mapping;
980
981 for (mapping = ada_opname_table;
1265e4aa 982 mapping->encoded != NULL
61012eef 983 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
984 ;
985 if (mapping->encoded == NULL)
b5ec771e
PA
986 {
987 if (throw_errors)
988 error (_("invalid Ada operator name: %s"), p);
989 else
990 return NULL;
991 }
4c4b4cd2
PH
992 strcpy (encoding_buffer + k, mapping->encoded);
993 k += strlen (mapping->encoded);
994 break;
995 }
d2e4a39e 996 else
4c4b4cd2
PH
997 {
998 encoding_buffer[k] = *p;
999 k += 1;
1000 }
14f9c5c9
AS
1001 }
1002
4c4b4cd2
PH
1003 encoding_buffer[k] = '\0';
1004 return encoding_buffer;
14f9c5c9
AS
1005}
1006
b5ec771e
PA
1007/* The "encoded" form of DECODED, according to GNAT conventions.
1008 The result is valid until the next call to ada_encode. */
1009
1010char *
1011ada_encode (const char *decoded)
1012{
1013 return ada_encode_1 (decoded, true);
1014}
1015
14f9c5c9 1016/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1017 quotes, unfolded, but with the quotes stripped away. Result good
1018 to next call. */
1019
d2e4a39e
AS
1020char *
1021ada_fold_name (const char *name)
14f9c5c9 1022{
d2e4a39e 1023 static char *fold_buffer = NULL;
14f9c5c9
AS
1024 static size_t fold_buffer_size = 0;
1025
1026 int len = strlen (name);
d2e4a39e 1027 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1028
1029 if (name[0] == '\'')
1030 {
d2e4a39e
AS
1031 strncpy (fold_buffer, name + 1, len - 2);
1032 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1033 }
1034 else
1035 {
1036 int i;
5b4ee69b 1037
14f9c5c9 1038 for (i = 0; i <= len; i += 1)
4c4b4cd2 1039 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1040 }
1041
1042 return fold_buffer;
1043}
1044
529cad9c
PH
1045/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1046
1047static int
1048is_lower_alphanum (const char c)
1049{
1050 return (isdigit (c) || (isalpha (c) && islower (c)));
1051}
1052
c90092fe
JB
1053/* ENCODED is the linkage name of a symbol and LEN contains its length.
1054 This function saves in LEN the length of that same symbol name but
1055 without either of these suffixes:
29480c32
JB
1056 . .{DIGIT}+
1057 . ${DIGIT}+
1058 . ___{DIGIT}+
1059 . __{DIGIT}+.
c90092fe 1060
29480c32
JB
1061 These are suffixes introduced by the compiler for entities such as
1062 nested subprogram for instance, in order to avoid name clashes.
1063 They do not serve any purpose for the debugger. */
1064
1065static void
1066ada_remove_trailing_digits (const char *encoded, int *len)
1067{
1068 if (*len > 1 && isdigit (encoded[*len - 1]))
1069 {
1070 int i = *len - 2;
5b4ee69b 1071
29480c32
JB
1072 while (i > 0 && isdigit (encoded[i]))
1073 i--;
1074 if (i >= 0 && encoded[i] == '.')
1075 *len = i;
1076 else if (i >= 0 && encoded[i] == '$')
1077 *len = i;
61012eef 1078 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1079 *len = i - 2;
61012eef 1080 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1081 *len = i - 1;
1082 }
1083}
1084
1085/* Remove the suffix introduced by the compiler for protected object
1086 subprograms. */
1087
1088static void
1089ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1090{
1091 /* Remove trailing N. */
1092
1093 /* Protected entry subprograms are broken into two
1094 separate subprograms: The first one is unprotected, and has
1095 a 'N' suffix; the second is the protected version, and has
0963b4bd 1096 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1097 the protection. Since the P subprograms are internally generated,
1098 we leave these names undecoded, giving the user a clue that this
1099 entity is internal. */
1100
1101 if (*len > 1
1102 && encoded[*len - 1] == 'N'
1103 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1104 *len = *len - 1;
1105}
1106
1107/* If ENCODED follows the GNAT entity encoding conventions, then return
1108 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1109 replaced by ENCODED.
14f9c5c9 1110
4c4b4cd2 1111 The resulting string is valid until the next call of ada_decode.
29480c32 1112 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1113 is returned. */
1114
1115const char *
1116ada_decode (const char *encoded)
14f9c5c9
AS
1117{
1118 int i, j;
1119 int len0;
d2e4a39e 1120 const char *p;
4c4b4cd2 1121 char *decoded;
14f9c5c9 1122 int at_start_name;
4c4b4cd2
PH
1123 static char *decoding_buffer = NULL;
1124 static size_t decoding_buffer_size = 0;
d2e4a39e 1125
0d81f350
JG
1126 /* With function descriptors on PPC64, the value of a symbol named
1127 ".FN", if it exists, is the entry point of the function "FN". */
1128 if (encoded[0] == '.')
1129 encoded += 1;
1130
29480c32
JB
1131 /* The name of the Ada main procedure starts with "_ada_".
1132 This prefix is not part of the decoded name, so skip this part
1133 if we see this prefix. */
61012eef 1134 if (startswith (encoded, "_ada_"))
4c4b4cd2 1135 encoded += 5;
14f9c5c9 1136
29480c32
JB
1137 /* If the name starts with '_', then it is not a properly encoded
1138 name, so do not attempt to decode it. Similarly, if the name
1139 starts with '<', the name should not be decoded. */
4c4b4cd2 1140 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1141 goto Suppress;
1142
4c4b4cd2 1143 len0 = strlen (encoded);
4c4b4cd2 1144
29480c32
JB
1145 ada_remove_trailing_digits (encoded, &len0);
1146 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1147
4c4b4cd2
PH
1148 /* Remove the ___X.* suffix if present. Do not forget to verify that
1149 the suffix is located before the current "end" of ENCODED. We want
1150 to avoid re-matching parts of ENCODED that have previously been
1151 marked as discarded (by decrementing LEN0). */
1152 p = strstr (encoded, "___");
1153 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1154 {
1155 if (p[3] == 'X')
4c4b4cd2 1156 len0 = p - encoded;
14f9c5c9 1157 else
4c4b4cd2 1158 goto Suppress;
14f9c5c9 1159 }
4c4b4cd2 1160
29480c32
JB
1161 /* Remove any trailing TKB suffix. It tells us that this symbol
1162 is for the body of a task, but that information does not actually
1163 appear in the decoded name. */
1164
61012eef 1165 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1166 len0 -= 3;
76a01679 1167
a10967fa
JB
1168 /* Remove any trailing TB suffix. The TB suffix is slightly different
1169 from the TKB suffix because it is used for non-anonymous task
1170 bodies. */
1171
61012eef 1172 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1173 len0 -= 2;
1174
29480c32
JB
1175 /* Remove trailing "B" suffixes. */
1176 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1177
61012eef 1178 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1179 len0 -= 1;
1180
4c4b4cd2 1181 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1182
4c4b4cd2
PH
1183 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1184 decoded = decoding_buffer;
14f9c5c9 1185
29480c32
JB
1186 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1187
4c4b4cd2 1188 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1189 {
4c4b4cd2
PH
1190 i = len0 - 2;
1191 while ((i >= 0 && isdigit (encoded[i]))
1192 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1193 i -= 1;
1194 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1195 len0 = i - 1;
1196 else if (encoded[i] == '$')
1197 len0 = i;
d2e4a39e 1198 }
14f9c5c9 1199
29480c32
JB
1200 /* The first few characters that are not alphabetic are not part
1201 of any encoding we use, so we can copy them over verbatim. */
1202
4c4b4cd2
PH
1203 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1204 decoded[j] = encoded[i];
14f9c5c9
AS
1205
1206 at_start_name = 1;
1207 while (i < len0)
1208 {
29480c32 1209 /* Is this a symbol function? */
4c4b4cd2
PH
1210 if (at_start_name && encoded[i] == 'O')
1211 {
1212 int k;
5b4ee69b 1213
4c4b4cd2
PH
1214 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1215 {
1216 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1217 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1218 op_len - 1) == 0)
1219 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1220 {
1221 strcpy (decoded + j, ada_opname_table[k].decoded);
1222 at_start_name = 0;
1223 i += op_len;
1224 j += strlen (ada_opname_table[k].decoded);
1225 break;
1226 }
1227 }
1228 if (ada_opname_table[k].encoded != NULL)
1229 continue;
1230 }
14f9c5c9
AS
1231 at_start_name = 0;
1232
529cad9c
PH
1233 /* Replace "TK__" with "__", which will eventually be translated
1234 into "." (just below). */
1235
61012eef 1236 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1237 i += 2;
529cad9c 1238
29480c32
JB
1239 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1240 be translated into "." (just below). These are internal names
1241 generated for anonymous blocks inside which our symbol is nested. */
1242
1243 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1244 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1245 && isdigit (encoded [i+4]))
1246 {
1247 int k = i + 5;
1248
1249 while (k < len0 && isdigit (encoded[k]))
1250 k++; /* Skip any extra digit. */
1251
1252 /* Double-check that the "__B_{DIGITS}+" sequence we found
1253 is indeed followed by "__". */
1254 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1255 i = k;
1256 }
1257
529cad9c
PH
1258 /* Remove _E{DIGITS}+[sb] */
1259
1260 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1261 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1262 one implements the actual entry code, and has a suffix following
1263 the convention above; the second one implements the barrier and
1264 uses the same convention as above, except that the 'E' is replaced
1265 by a 'B'.
1266
1267 Just as above, we do not decode the name of barrier functions
1268 to give the user a clue that the code he is debugging has been
1269 internally generated. */
1270
1271 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1272 && isdigit (encoded[i+2]))
1273 {
1274 int k = i + 3;
1275
1276 while (k < len0 && isdigit (encoded[k]))
1277 k++;
1278
1279 if (k < len0
1280 && (encoded[k] == 'b' || encoded[k] == 's'))
1281 {
1282 k++;
1283 /* Just as an extra precaution, make sure that if this
1284 suffix is followed by anything else, it is a '_'.
1285 Otherwise, we matched this sequence by accident. */
1286 if (k == len0
1287 || (k < len0 && encoded[k] == '_'))
1288 i = k;
1289 }
1290 }
1291
1292 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1293 the GNAT front-end in protected object subprograms. */
1294
1295 if (i < len0 + 3
1296 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1297 {
1298 /* Backtrack a bit up until we reach either the begining of
1299 the encoded name, or "__". Make sure that we only find
1300 digits or lowercase characters. */
1301 const char *ptr = encoded + i - 1;
1302
1303 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1304 ptr--;
1305 if (ptr < encoded
1306 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1307 i++;
1308 }
1309
4c4b4cd2
PH
1310 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1311 {
29480c32
JB
1312 /* This is a X[bn]* sequence not separated from the previous
1313 part of the name with a non-alpha-numeric character (in other
1314 words, immediately following an alpha-numeric character), then
1315 verify that it is placed at the end of the encoded name. If
1316 not, then the encoding is not valid and we should abort the
1317 decoding. Otherwise, just skip it, it is used in body-nested
1318 package names. */
4c4b4cd2
PH
1319 do
1320 i += 1;
1321 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1322 if (i < len0)
1323 goto Suppress;
1324 }
cdc7bb92 1325 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1326 {
29480c32 1327 /* Replace '__' by '.'. */
4c4b4cd2
PH
1328 decoded[j] = '.';
1329 at_start_name = 1;
1330 i += 2;
1331 j += 1;
1332 }
14f9c5c9 1333 else
4c4b4cd2 1334 {
29480c32
JB
1335 /* It's a character part of the decoded name, so just copy it
1336 over. */
4c4b4cd2
PH
1337 decoded[j] = encoded[i];
1338 i += 1;
1339 j += 1;
1340 }
14f9c5c9 1341 }
4c4b4cd2 1342 decoded[j] = '\000';
14f9c5c9 1343
29480c32
JB
1344 /* Decoded names should never contain any uppercase character.
1345 Double-check this, and abort the decoding if we find one. */
1346
4c4b4cd2
PH
1347 for (i = 0; decoded[i] != '\0'; i += 1)
1348 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1349 goto Suppress;
1350
4c4b4cd2
PH
1351 if (strcmp (decoded, encoded) == 0)
1352 return encoded;
1353 else
1354 return decoded;
14f9c5c9
AS
1355
1356Suppress:
4c4b4cd2
PH
1357 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1358 decoded = decoding_buffer;
1359 if (encoded[0] == '<')
1360 strcpy (decoded, encoded);
14f9c5c9 1361 else
88c15c34 1362 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1363 return decoded;
1364
1365}
1366
1367/* Table for keeping permanent unique copies of decoded names. Once
1368 allocated, names in this table are never released. While this is a
1369 storage leak, it should not be significant unless there are massive
1370 changes in the set of decoded names in successive versions of a
1371 symbol table loaded during a single session. */
1372static struct htab *decoded_names_store;
1373
1374/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1375 in the language-specific part of GSYMBOL, if it has not been
1376 previously computed. Tries to save the decoded name in the same
1377 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1378 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1379 GSYMBOL).
4c4b4cd2
PH
1380 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1381 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1382 when a decoded name is cached in it. */
4c4b4cd2 1383
45e6c716 1384const char *
f85f34ed 1385ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1386{
f85f34ed
TT
1387 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1388 const char **resultp =
615b3f62 1389 &gsymbol->language_specific.demangled_name;
5b4ee69b 1390
f85f34ed 1391 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1392 {
1393 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1394 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1395
f85f34ed 1396 gsymbol->ada_mangled = 1;
5b4ee69b 1397
f85f34ed 1398 if (obstack != NULL)
224c3ddb
SM
1399 *resultp
1400 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1401 else
76a01679 1402 {
f85f34ed
TT
1403 /* Sometimes, we can't find a corresponding objfile, in
1404 which case, we put the result on the heap. Since we only
1405 decode when needed, we hope this usually does not cause a
1406 significant memory leak (FIXME). */
1407
76a01679
JB
1408 char **slot = (char **) htab_find_slot (decoded_names_store,
1409 decoded, INSERT);
5b4ee69b 1410
76a01679
JB
1411 if (*slot == NULL)
1412 *slot = xstrdup (decoded);
1413 *resultp = *slot;
1414 }
4c4b4cd2 1415 }
14f9c5c9 1416
4c4b4cd2
PH
1417 return *resultp;
1418}
76a01679 1419
2c0b251b 1420static char *
76a01679 1421ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1422{
1423 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1424}
1425
8b302db8
TT
1426/* Implement la_sniff_from_mangled_name for Ada. */
1427
1428static int
1429ada_sniff_from_mangled_name (const char *mangled, char **out)
1430{
1431 const char *demangled = ada_decode (mangled);
1432
1433 *out = NULL;
1434
1435 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1436 {
1437 /* Set the gsymbol language to Ada, but still return 0.
1438 Two reasons for that:
1439
1440 1. For Ada, we prefer computing the symbol's decoded name
1441 on the fly rather than pre-compute it, in order to save
1442 memory (Ada projects are typically very large).
1443
1444 2. There are some areas in the definition of the GNAT
1445 encoding where, with a bit of bad luck, we might be able
1446 to decode a non-Ada symbol, generating an incorrect
1447 demangled name (Eg: names ending with "TB" for instance
1448 are identified as task bodies and so stripped from
1449 the decoded name returned).
1450
1451 Returning 1, here, but not setting *DEMANGLED, helps us get a
1452 little bit of the best of both worlds. Because we're last,
1453 we should not affect any of the other languages that were
1454 able to demangle the symbol before us; we get to correctly
1455 tag Ada symbols as such; and even if we incorrectly tagged a
1456 non-Ada symbol, which should be rare, any routing through the
1457 Ada language should be transparent (Ada tries to behave much
1458 like C/C++ with non-Ada symbols). */
1459 return 1;
1460 }
1461
1462 return 0;
1463}
1464
14f9c5c9 1465\f
d2e4a39e 1466
4c4b4cd2 1467 /* Arrays */
14f9c5c9 1468
28c85d6c
JB
1469/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1470 generated by the GNAT compiler to describe the index type used
1471 for each dimension of an array, check whether it follows the latest
1472 known encoding. If not, fix it up to conform to the latest encoding.
1473 Otherwise, do nothing. This function also does nothing if
1474 INDEX_DESC_TYPE is NULL.
1475
1476 The GNAT encoding used to describle the array index type evolved a bit.
1477 Initially, the information would be provided through the name of each
1478 field of the structure type only, while the type of these fields was
1479 described as unspecified and irrelevant. The debugger was then expected
1480 to perform a global type lookup using the name of that field in order
1481 to get access to the full index type description. Because these global
1482 lookups can be very expensive, the encoding was later enhanced to make
1483 the global lookup unnecessary by defining the field type as being
1484 the full index type description.
1485
1486 The purpose of this routine is to allow us to support older versions
1487 of the compiler by detecting the use of the older encoding, and by
1488 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1489 we essentially replace each field's meaningless type by the associated
1490 index subtype). */
1491
1492void
1493ada_fixup_array_indexes_type (struct type *index_desc_type)
1494{
1495 int i;
1496
1497 if (index_desc_type == NULL)
1498 return;
1499 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1500
1501 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1502 to check one field only, no need to check them all). If not, return
1503 now.
1504
1505 If our INDEX_DESC_TYPE was generated using the older encoding,
1506 the field type should be a meaningless integer type whose name
1507 is not equal to the field name. */
1508 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1509 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1510 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1511 return;
1512
1513 /* Fixup each field of INDEX_DESC_TYPE. */
1514 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1515 {
0d5cff50 1516 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1517 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1518
1519 if (raw_type)
1520 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1521 }
1522}
1523
4c4b4cd2 1524/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1525
a121b7c1 1526static const char *bound_name[] = {
d2e4a39e 1527 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1528 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1529};
1530
1531/* Maximum number of array dimensions we are prepared to handle. */
1532
4c4b4cd2 1533#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1534
14f9c5c9 1535
4c4b4cd2
PH
1536/* The desc_* routines return primitive portions of array descriptors
1537 (fat pointers). */
14f9c5c9
AS
1538
1539/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1540 level of indirection, if needed. */
1541
d2e4a39e
AS
1542static struct type *
1543desc_base_type (struct type *type)
14f9c5c9
AS
1544{
1545 if (type == NULL)
1546 return NULL;
61ee279c 1547 type = ada_check_typedef (type);
720d1a40
JB
1548 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1549 type = ada_typedef_target_type (type);
1550
1265e4aa
JB
1551 if (type != NULL
1552 && (TYPE_CODE (type) == TYPE_CODE_PTR
1553 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1554 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1555 else
1556 return type;
1557}
1558
4c4b4cd2
PH
1559/* True iff TYPE indicates a "thin" array pointer type. */
1560
14f9c5c9 1561static int
d2e4a39e 1562is_thin_pntr (struct type *type)
14f9c5c9 1563{
d2e4a39e 1564 return
14f9c5c9
AS
1565 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1566 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1567}
1568
4c4b4cd2
PH
1569/* The descriptor type for thin pointer type TYPE. */
1570
d2e4a39e
AS
1571static struct type *
1572thin_descriptor_type (struct type *type)
14f9c5c9 1573{
d2e4a39e 1574 struct type *base_type = desc_base_type (type);
5b4ee69b 1575
14f9c5c9
AS
1576 if (base_type == NULL)
1577 return NULL;
1578 if (is_suffix (ada_type_name (base_type), "___XVE"))
1579 return base_type;
d2e4a39e 1580 else
14f9c5c9 1581 {
d2e4a39e 1582 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1583
14f9c5c9 1584 if (alt_type == NULL)
4c4b4cd2 1585 return base_type;
14f9c5c9 1586 else
4c4b4cd2 1587 return alt_type;
14f9c5c9
AS
1588 }
1589}
1590
4c4b4cd2
PH
1591/* A pointer to the array data for thin-pointer value VAL. */
1592
d2e4a39e
AS
1593static struct value *
1594thin_data_pntr (struct value *val)
14f9c5c9 1595{
828292f2 1596 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1597 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1598
556bdfd4
UW
1599 data_type = lookup_pointer_type (data_type);
1600
14f9c5c9 1601 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1602 return value_cast (data_type, value_copy (val));
d2e4a39e 1603 else
42ae5230 1604 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1605}
1606
4c4b4cd2
PH
1607/* True iff TYPE indicates a "thick" array pointer type. */
1608
14f9c5c9 1609static int
d2e4a39e 1610is_thick_pntr (struct type *type)
14f9c5c9
AS
1611{
1612 type = desc_base_type (type);
1613 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1614 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1615}
1616
4c4b4cd2
PH
1617/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1618 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1619
d2e4a39e
AS
1620static struct type *
1621desc_bounds_type (struct type *type)
14f9c5c9 1622{
d2e4a39e 1623 struct type *r;
14f9c5c9
AS
1624
1625 type = desc_base_type (type);
1626
1627 if (type == NULL)
1628 return NULL;
1629 else if (is_thin_pntr (type))
1630 {
1631 type = thin_descriptor_type (type);
1632 if (type == NULL)
4c4b4cd2 1633 return NULL;
14f9c5c9
AS
1634 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1635 if (r != NULL)
61ee279c 1636 return ada_check_typedef (r);
14f9c5c9
AS
1637 }
1638 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1639 {
1640 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1641 if (r != NULL)
61ee279c 1642 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1643 }
1644 return NULL;
1645}
1646
1647/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1648 one, a pointer to its bounds data. Otherwise NULL. */
1649
d2e4a39e
AS
1650static struct value *
1651desc_bounds (struct value *arr)
14f9c5c9 1652{
df407dfe 1653 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1654
d2e4a39e 1655 if (is_thin_pntr (type))
14f9c5c9 1656 {
d2e4a39e 1657 struct type *bounds_type =
4c4b4cd2 1658 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1659 LONGEST addr;
1660
4cdfadb1 1661 if (bounds_type == NULL)
323e0a4a 1662 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1663
1664 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1665 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1666 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1667 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1668 addr = value_as_long (arr);
d2e4a39e 1669 else
42ae5230 1670 addr = value_address (arr);
14f9c5c9 1671
d2e4a39e 1672 return
4c4b4cd2
PH
1673 value_from_longest (lookup_pointer_type (bounds_type),
1674 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1675 }
1676
1677 else if (is_thick_pntr (type))
05e522ef
JB
1678 {
1679 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1680 _("Bad GNAT array descriptor"));
1681 struct type *p_bounds_type = value_type (p_bounds);
1682
1683 if (p_bounds_type
1684 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1685 {
1686 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1687
1688 if (TYPE_STUB (target_type))
1689 p_bounds = value_cast (lookup_pointer_type
1690 (ada_check_typedef (target_type)),
1691 p_bounds);
1692 }
1693 else
1694 error (_("Bad GNAT array descriptor"));
1695
1696 return p_bounds;
1697 }
14f9c5c9
AS
1698 else
1699 return NULL;
1700}
1701
4c4b4cd2
PH
1702/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1703 position of the field containing the address of the bounds data. */
1704
14f9c5c9 1705static int
d2e4a39e 1706fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1707{
1708 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1709}
1710
1711/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1712 size of the field containing the address of the bounds data. */
1713
14f9c5c9 1714static int
d2e4a39e 1715fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1716{
1717 type = desc_base_type (type);
1718
d2e4a39e 1719 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1720 return TYPE_FIELD_BITSIZE (type, 1);
1721 else
61ee279c 1722 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1723}
1724
4c4b4cd2 1725/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1726 pointer to one, the type of its array data (a array-with-no-bounds type);
1727 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1728 data. */
4c4b4cd2 1729
d2e4a39e 1730static struct type *
556bdfd4 1731desc_data_target_type (struct type *type)
14f9c5c9
AS
1732{
1733 type = desc_base_type (type);
1734
4c4b4cd2 1735 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1736 if (is_thin_pntr (type))
556bdfd4 1737 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1738 else if (is_thick_pntr (type))
556bdfd4
UW
1739 {
1740 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1741
1742 if (data_type
1743 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1744 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1745 }
1746
1747 return NULL;
14f9c5c9
AS
1748}
1749
1750/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1751 its array data. */
4c4b4cd2 1752
d2e4a39e
AS
1753static struct value *
1754desc_data (struct value *arr)
14f9c5c9 1755{
df407dfe 1756 struct type *type = value_type (arr);
5b4ee69b 1757
14f9c5c9
AS
1758 if (is_thin_pntr (type))
1759 return thin_data_pntr (arr);
1760 else if (is_thick_pntr (type))
d2e4a39e 1761 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1762 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1763 else
1764 return NULL;
1765}
1766
1767
1768/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1769 position of the field containing the address of the data. */
1770
14f9c5c9 1771static int
d2e4a39e 1772fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1773{
1774 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1775}
1776
1777/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1778 size of the field containing the address of the data. */
1779
14f9c5c9 1780static int
d2e4a39e 1781fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1782{
1783 type = desc_base_type (type);
1784
1785 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1786 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1787 else
14f9c5c9
AS
1788 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1789}
1790
4c4b4cd2 1791/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1792 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1793 bound, if WHICH is 1. The first bound is I=1. */
1794
d2e4a39e
AS
1795static struct value *
1796desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1797{
d2e4a39e 1798 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1799 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1800}
1801
1802/* If BOUNDS is an array-bounds structure type, return the bit position
1803 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1804 bound, if WHICH is 1. The first bound is I=1. */
1805
14f9c5c9 1806static int
d2e4a39e 1807desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1808{
d2e4a39e 1809 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1810}
1811
1812/* If BOUNDS is an array-bounds structure type, return the bit field size
1813 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1814 bound, if WHICH is 1. The first bound is I=1. */
1815
76a01679 1816static int
d2e4a39e 1817desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1818{
1819 type = desc_base_type (type);
1820
d2e4a39e
AS
1821 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1822 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1823 else
1824 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1825}
1826
1827/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1828 Ith bound (numbering from 1). Otherwise, NULL. */
1829
d2e4a39e
AS
1830static struct type *
1831desc_index_type (struct type *type, int i)
14f9c5c9
AS
1832{
1833 type = desc_base_type (type);
1834
1835 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1836 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1837 else
14f9c5c9
AS
1838 return NULL;
1839}
1840
4c4b4cd2
PH
1841/* The number of index positions in the array-bounds type TYPE.
1842 Return 0 if TYPE is NULL. */
1843
14f9c5c9 1844static int
d2e4a39e 1845desc_arity (struct type *type)
14f9c5c9
AS
1846{
1847 type = desc_base_type (type);
1848
1849 if (type != NULL)
1850 return TYPE_NFIELDS (type) / 2;
1851 return 0;
1852}
1853
4c4b4cd2
PH
1854/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1855 an array descriptor type (representing an unconstrained array
1856 type). */
1857
76a01679
JB
1858static int
1859ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1860{
1861 if (type == NULL)
1862 return 0;
61ee279c 1863 type = ada_check_typedef (type);
4c4b4cd2 1864 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1865 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1866}
1867
52ce6436 1868/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1869 * to one. */
52ce6436 1870
2c0b251b 1871static int
52ce6436
PH
1872ada_is_array_type (struct type *type)
1873{
1874 while (type != NULL
1875 && (TYPE_CODE (type) == TYPE_CODE_PTR
1876 || TYPE_CODE (type) == TYPE_CODE_REF))
1877 type = TYPE_TARGET_TYPE (type);
1878 return ada_is_direct_array_type (type);
1879}
1880
4c4b4cd2 1881/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1882
14f9c5c9 1883int
4c4b4cd2 1884ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1885{
1886 if (type == NULL)
1887 return 0;
61ee279c 1888 type = ada_check_typedef (type);
14f9c5c9 1889 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1890 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1891 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1892 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1893}
1894
4c4b4cd2
PH
1895/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1896
14f9c5c9 1897int
4c4b4cd2 1898ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1899{
556bdfd4 1900 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1901
1902 if (type == NULL)
1903 return 0;
61ee279c 1904 type = ada_check_typedef (type);
556bdfd4
UW
1905 return (data_type != NULL
1906 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1907 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1908}
1909
1910/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1911 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1912 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1913 is still needed. */
1914
14f9c5c9 1915int
ebf56fd3 1916ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1917{
d2e4a39e 1918 return
14f9c5c9
AS
1919 type != NULL
1920 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1921 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1922 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1923 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1924}
1925
1926
4c4b4cd2 1927/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1928 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1929 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1930 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1931 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1932 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1933 a descriptor. */
d2e4a39e
AS
1934struct type *
1935ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1936{
ad82864c
JB
1937 if (ada_is_constrained_packed_array_type (value_type (arr)))
1938 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1939
df407dfe
AC
1940 if (!ada_is_array_descriptor_type (value_type (arr)))
1941 return value_type (arr);
d2e4a39e
AS
1942
1943 if (!bounds)
ad82864c
JB
1944 {
1945 struct type *array_type =
1946 ada_check_typedef (desc_data_target_type (value_type (arr)));
1947
1948 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1949 TYPE_FIELD_BITSIZE (array_type, 0) =
1950 decode_packed_array_bitsize (value_type (arr));
1951
1952 return array_type;
1953 }
14f9c5c9
AS
1954 else
1955 {
d2e4a39e 1956 struct type *elt_type;
14f9c5c9 1957 int arity;
d2e4a39e 1958 struct value *descriptor;
14f9c5c9 1959
df407dfe
AC
1960 elt_type = ada_array_element_type (value_type (arr), -1);
1961 arity = ada_array_arity (value_type (arr));
14f9c5c9 1962
d2e4a39e 1963 if (elt_type == NULL || arity == 0)
df407dfe 1964 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1965
1966 descriptor = desc_bounds (arr);
d2e4a39e 1967 if (value_as_long (descriptor) == 0)
4c4b4cd2 1968 return NULL;
d2e4a39e 1969 while (arity > 0)
4c4b4cd2 1970 {
e9bb382b
UW
1971 struct type *range_type = alloc_type_copy (value_type (arr));
1972 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1973 struct value *low = desc_one_bound (descriptor, arity, 0);
1974 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1975
5b4ee69b 1976 arity -= 1;
0c9c3474
SA
1977 create_static_range_type (range_type, value_type (low),
1978 longest_to_int (value_as_long (low)),
1979 longest_to_int (value_as_long (high)));
4c4b4cd2 1980 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1981
1982 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1983 {
1984 /* We need to store the element packed bitsize, as well as
1985 recompute the array size, because it was previously
1986 computed based on the unpacked element size. */
1987 LONGEST lo = value_as_long (low);
1988 LONGEST hi = value_as_long (high);
1989
1990 TYPE_FIELD_BITSIZE (elt_type, 0) =
1991 decode_packed_array_bitsize (value_type (arr));
1992 /* If the array has no element, then the size is already
1993 zero, and does not need to be recomputed. */
1994 if (lo < hi)
1995 {
1996 int array_bitsize =
1997 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1998
1999 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2000 }
2001 }
4c4b4cd2 2002 }
14f9c5c9
AS
2003
2004 return lookup_pointer_type (elt_type);
2005 }
2006}
2007
2008/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2009 Otherwise, returns either a standard GDB array with bounds set
2010 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2011 GDB array. Returns NULL if ARR is a null fat pointer. */
2012
d2e4a39e
AS
2013struct value *
2014ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2015{
df407dfe 2016 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2017 {
d2e4a39e 2018 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2019
14f9c5c9 2020 if (arrType == NULL)
4c4b4cd2 2021 return NULL;
14f9c5c9
AS
2022 return value_cast (arrType, value_copy (desc_data (arr)));
2023 }
ad82864c
JB
2024 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2025 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2026 else
2027 return arr;
2028}
2029
2030/* If ARR does not represent an array, returns ARR unchanged.
2031 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2032 be ARR itself if it already is in the proper form). */
2033
720d1a40 2034struct value *
d2e4a39e 2035ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2036{
df407dfe 2037 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2038 {
d2e4a39e 2039 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2040
14f9c5c9 2041 if (arrVal == NULL)
323e0a4a 2042 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2043 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2044 return value_ind (arrVal);
2045 }
ad82864c
JB
2046 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2047 return decode_constrained_packed_array (arr);
d2e4a39e 2048 else
14f9c5c9
AS
2049 return arr;
2050}
2051
2052/* If TYPE represents a GNAT array type, return it translated to an
2053 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2054 packing). For other types, is the identity. */
2055
d2e4a39e
AS
2056struct type *
2057ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2058{
ad82864c
JB
2059 if (ada_is_constrained_packed_array_type (type))
2060 return decode_constrained_packed_array_type (type);
17280b9f
UW
2061
2062 if (ada_is_array_descriptor_type (type))
556bdfd4 2063 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2064
2065 return type;
14f9c5c9
AS
2066}
2067
4c4b4cd2
PH
2068/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2069
ad82864c
JB
2070static int
2071ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2072{
2073 if (type == NULL)
2074 return 0;
4c4b4cd2 2075 type = desc_base_type (type);
61ee279c 2076 type = ada_check_typedef (type);
d2e4a39e 2077 return
14f9c5c9
AS
2078 ada_type_name (type) != NULL
2079 && strstr (ada_type_name (type), "___XP") != NULL;
2080}
2081
ad82864c
JB
2082/* Non-zero iff TYPE represents a standard GNAT constrained
2083 packed-array type. */
2084
2085int
2086ada_is_constrained_packed_array_type (struct type *type)
2087{
2088 return ada_is_packed_array_type (type)
2089 && !ada_is_array_descriptor_type (type);
2090}
2091
2092/* Non-zero iff TYPE represents an array descriptor for a
2093 unconstrained packed-array type. */
2094
2095static int
2096ada_is_unconstrained_packed_array_type (struct type *type)
2097{
2098 return ada_is_packed_array_type (type)
2099 && ada_is_array_descriptor_type (type);
2100}
2101
2102/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2103 return the size of its elements in bits. */
2104
2105static long
2106decode_packed_array_bitsize (struct type *type)
2107{
0d5cff50
DE
2108 const char *raw_name;
2109 const char *tail;
ad82864c
JB
2110 long bits;
2111
720d1a40
JB
2112 /* Access to arrays implemented as fat pointers are encoded as a typedef
2113 of the fat pointer type. We need the name of the fat pointer type
2114 to do the decoding, so strip the typedef layer. */
2115 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2116 type = ada_typedef_target_type (type);
2117
2118 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2119 if (!raw_name)
2120 raw_name = ada_type_name (desc_base_type (type));
2121
2122 if (!raw_name)
2123 return 0;
2124
2125 tail = strstr (raw_name, "___XP");
720d1a40 2126 gdb_assert (tail != NULL);
ad82864c
JB
2127
2128 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2129 {
2130 lim_warning
2131 (_("could not understand bit size information on packed array"));
2132 return 0;
2133 }
2134
2135 return bits;
2136}
2137
14f9c5c9
AS
2138/* Given that TYPE is a standard GDB array type with all bounds filled
2139 in, and that the element size of its ultimate scalar constituents
2140 (that is, either its elements, or, if it is an array of arrays, its
2141 elements' elements, etc.) is *ELT_BITS, return an identical type,
2142 but with the bit sizes of its elements (and those of any
2143 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2144 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2145 in bits.
2146
2147 Note that, for arrays whose index type has an XA encoding where
2148 a bound references a record discriminant, getting that discriminant,
2149 and therefore the actual value of that bound, is not possible
2150 because none of the given parameters gives us access to the record.
2151 This function assumes that it is OK in the context where it is being
2152 used to return an array whose bounds are still dynamic and where
2153 the length is arbitrary. */
4c4b4cd2 2154
d2e4a39e 2155static struct type *
ad82864c 2156constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2157{
d2e4a39e
AS
2158 struct type *new_elt_type;
2159 struct type *new_type;
99b1c762
JB
2160 struct type *index_type_desc;
2161 struct type *index_type;
14f9c5c9
AS
2162 LONGEST low_bound, high_bound;
2163
61ee279c 2164 type = ada_check_typedef (type);
14f9c5c9
AS
2165 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2166 return type;
2167
99b1c762
JB
2168 index_type_desc = ada_find_parallel_type (type, "___XA");
2169 if (index_type_desc)
2170 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2171 NULL);
2172 else
2173 index_type = TYPE_INDEX_TYPE (type);
2174
e9bb382b 2175 new_type = alloc_type_copy (type);
ad82864c
JB
2176 new_elt_type =
2177 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2178 elt_bits);
99b1c762 2179 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2180 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2181 TYPE_NAME (new_type) = ada_type_name (type);
2182
4a46959e
JB
2183 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2184 && is_dynamic_type (check_typedef (index_type)))
2185 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2186 low_bound = high_bound = 0;
2187 if (high_bound < low_bound)
2188 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2189 else
14f9c5c9
AS
2190 {
2191 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2192 TYPE_LENGTH (new_type) =
4c4b4cd2 2193 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2194 }
2195
876cecd0 2196 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2197 return new_type;
2198}
2199
ad82864c
JB
2200/* The array type encoded by TYPE, where
2201 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2202
d2e4a39e 2203static struct type *
ad82864c 2204decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2205{
0d5cff50 2206 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2207 char *name;
0d5cff50 2208 const char *tail;
d2e4a39e 2209 struct type *shadow_type;
14f9c5c9 2210 long bits;
14f9c5c9 2211
727e3d2e
JB
2212 if (!raw_name)
2213 raw_name = ada_type_name (desc_base_type (type));
2214
2215 if (!raw_name)
2216 return NULL;
2217
2218 name = (char *) alloca (strlen (raw_name) + 1);
2219 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2220 type = desc_base_type (type);
2221
14f9c5c9
AS
2222 memcpy (name, raw_name, tail - raw_name);
2223 name[tail - raw_name] = '\000';
2224
b4ba55a1
JB
2225 shadow_type = ada_find_parallel_type_with_name (type, name);
2226
2227 if (shadow_type == NULL)
14f9c5c9 2228 {
323e0a4a 2229 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2230 return NULL;
2231 }
f168693b 2232 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2233
2234 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2235 {
0963b4bd
MS
2236 lim_warning (_("could not understand bounds "
2237 "information on packed array"));
14f9c5c9
AS
2238 return NULL;
2239 }
d2e4a39e 2240
ad82864c
JB
2241 bits = decode_packed_array_bitsize (type);
2242 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2243}
2244
ad82864c
JB
2245/* Given that ARR is a struct value *indicating a GNAT constrained packed
2246 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2247 standard GDB array type except that the BITSIZEs of the array
2248 target types are set to the number of bits in each element, and the
4c4b4cd2 2249 type length is set appropriately. */
14f9c5c9 2250
d2e4a39e 2251static struct value *
ad82864c 2252decode_constrained_packed_array (struct value *arr)
14f9c5c9 2253{
4c4b4cd2 2254 struct type *type;
14f9c5c9 2255
11aa919a
PMR
2256 /* If our value is a pointer, then dereference it. Likewise if
2257 the value is a reference. Make sure that this operation does not
2258 cause the target type to be fixed, as this would indirectly cause
2259 this array to be decoded. The rest of the routine assumes that
2260 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2261 and "value_ind" routines to perform the dereferencing, as opposed
2262 to using "ada_coerce_ref" or "ada_value_ind". */
2263 arr = coerce_ref (arr);
828292f2 2264 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2265 arr = value_ind (arr);
4c4b4cd2 2266
ad82864c 2267 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2268 if (type == NULL)
2269 {
323e0a4a 2270 error (_("can't unpack array"));
14f9c5c9
AS
2271 return NULL;
2272 }
61ee279c 2273
50810684 2274 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2275 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2276 {
2277 /* This is a (right-justified) modular type representing a packed
2278 array with no wrapper. In order to interpret the value through
2279 the (left-justified) packed array type we just built, we must
2280 first left-justify it. */
2281 int bit_size, bit_pos;
2282 ULONGEST mod;
2283
df407dfe 2284 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2285 bit_size = 0;
2286 while (mod > 0)
2287 {
2288 bit_size += 1;
2289 mod >>= 1;
2290 }
df407dfe 2291 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2292 arr = ada_value_primitive_packed_val (arr, NULL,
2293 bit_pos / HOST_CHAR_BIT,
2294 bit_pos % HOST_CHAR_BIT,
2295 bit_size,
2296 type);
2297 }
2298
4c4b4cd2 2299 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2300}
2301
2302
2303/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2304 given in IND. ARR must be a simple array. */
14f9c5c9 2305
d2e4a39e
AS
2306static struct value *
2307value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2308{
2309 int i;
2310 int bits, elt_off, bit_off;
2311 long elt_total_bit_offset;
d2e4a39e
AS
2312 struct type *elt_type;
2313 struct value *v;
14f9c5c9
AS
2314
2315 bits = 0;
2316 elt_total_bit_offset = 0;
df407dfe 2317 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2318 for (i = 0; i < arity; i += 1)
14f9c5c9 2319 {
d2e4a39e 2320 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2321 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2322 error
0963b4bd
MS
2323 (_("attempt to do packed indexing of "
2324 "something other than a packed array"));
14f9c5c9 2325 else
4c4b4cd2
PH
2326 {
2327 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2328 LONGEST lowerbound, upperbound;
2329 LONGEST idx;
2330
2331 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2332 {
323e0a4a 2333 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2334 lowerbound = upperbound = 0;
2335 }
2336
3cb382c9 2337 idx = pos_atr (ind[i]);
4c4b4cd2 2338 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2339 lim_warning (_("packed array index %ld out of bounds"),
2340 (long) idx);
4c4b4cd2
PH
2341 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2342 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2343 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2344 }
14f9c5c9
AS
2345 }
2346 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2347 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2348
2349 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2350 bits, elt_type);
14f9c5c9
AS
2351 return v;
2352}
2353
4c4b4cd2 2354/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2355
2356static int
d2e4a39e 2357has_negatives (struct type *type)
14f9c5c9 2358{
d2e4a39e
AS
2359 switch (TYPE_CODE (type))
2360 {
2361 default:
2362 return 0;
2363 case TYPE_CODE_INT:
2364 return !TYPE_UNSIGNED (type);
2365 case TYPE_CODE_RANGE:
2366 return TYPE_LOW_BOUND (type) < 0;
2367 }
14f9c5c9 2368}
d2e4a39e 2369
f93fca70 2370/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2371 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2372 the unpacked buffer.
14f9c5c9 2373
5b639dea
JB
2374 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2375 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2376
f93fca70
JB
2377 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2378 zero otherwise.
14f9c5c9 2379
f93fca70 2380 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2381
f93fca70
JB
2382 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2383
2384static void
2385ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2386 gdb_byte *unpacked, int unpacked_len,
2387 int is_big_endian, int is_signed_type,
2388 int is_scalar)
2389{
a1c95e6b
JB
2390 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2391 int src_idx; /* Index into the source area */
2392 int src_bytes_left; /* Number of source bytes left to process. */
2393 int srcBitsLeft; /* Number of source bits left to move */
2394 int unusedLS; /* Number of bits in next significant
2395 byte of source that are unused */
2396
a1c95e6b
JB
2397 int unpacked_idx; /* Index into the unpacked buffer */
2398 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2399
4c4b4cd2 2400 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2401 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2402 unsigned char sign;
a1c95e6b 2403
4c4b4cd2
PH
2404 /* Transmit bytes from least to most significant; delta is the direction
2405 the indices move. */
f93fca70 2406 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2407
5b639dea
JB
2408 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2409 bits from SRC. .*/
2410 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2411 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2412 bit_size, unpacked_len);
2413
14f9c5c9 2414 srcBitsLeft = bit_size;
086ca51f 2415 src_bytes_left = src_len;
f93fca70 2416 unpacked_bytes_left = unpacked_len;
14f9c5c9 2417 sign = 0;
f93fca70
JB
2418
2419 if (is_big_endian)
14f9c5c9 2420 {
086ca51f 2421 src_idx = src_len - 1;
f93fca70
JB
2422 if (is_signed_type
2423 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2424 sign = ~0;
d2e4a39e
AS
2425
2426 unusedLS =
4c4b4cd2
PH
2427 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2428 % HOST_CHAR_BIT;
14f9c5c9 2429
f93fca70
JB
2430 if (is_scalar)
2431 {
2432 accumSize = 0;
2433 unpacked_idx = unpacked_len - 1;
2434 }
2435 else
2436 {
4c4b4cd2
PH
2437 /* Non-scalar values must be aligned at a byte boundary... */
2438 accumSize =
2439 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2440 /* ... And are placed at the beginning (most-significant) bytes
2441 of the target. */
086ca51f
JB
2442 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2443 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2444 }
14f9c5c9 2445 }
d2e4a39e 2446 else
14f9c5c9
AS
2447 {
2448 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2449
086ca51f 2450 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2451 unusedLS = bit_offset;
2452 accumSize = 0;
2453
f93fca70 2454 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2455 sign = ~0;
14f9c5c9 2456 }
d2e4a39e 2457
14f9c5c9 2458 accum = 0;
086ca51f 2459 while (src_bytes_left > 0)
14f9c5c9
AS
2460 {
2461 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2462 part of the value. */
d2e4a39e 2463 unsigned int unusedMSMask =
4c4b4cd2
PH
2464 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2465 1;
2466 /* Sign-extend bits for this byte. */
14f9c5c9 2467 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2468
d2e4a39e 2469 accum |=
086ca51f 2470 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2471 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2472 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2473 {
db297a65 2474 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2475 accumSize -= HOST_CHAR_BIT;
2476 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2477 unpacked_bytes_left -= 1;
2478 unpacked_idx += delta;
4c4b4cd2 2479 }
14f9c5c9
AS
2480 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2481 unusedLS = 0;
086ca51f
JB
2482 src_bytes_left -= 1;
2483 src_idx += delta;
14f9c5c9 2484 }
086ca51f 2485 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2486 {
2487 accum |= sign << accumSize;
db297a65 2488 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2489 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2490 if (accumSize < 0)
2491 accumSize = 0;
14f9c5c9 2492 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2493 unpacked_bytes_left -= 1;
2494 unpacked_idx += delta;
14f9c5c9 2495 }
f93fca70
JB
2496}
2497
2498/* Create a new value of type TYPE from the contents of OBJ starting
2499 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2500 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2501 assigning through the result will set the field fetched from.
2502 VALADDR is ignored unless OBJ is NULL, in which case,
2503 VALADDR+OFFSET must address the start of storage containing the
2504 packed value. The value returned in this case is never an lval.
2505 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2506
2507struct value *
2508ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2509 long offset, int bit_offset, int bit_size,
2510 struct type *type)
2511{
2512 struct value *v;
bfb1c796 2513 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2514 gdb_byte *unpacked;
220475ed 2515 const int is_scalar = is_scalar_type (type);
d0a9e810 2516 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2517 gdb::byte_vector staging;
f93fca70
JB
2518
2519 type = ada_check_typedef (type);
2520
d0a9e810 2521 if (obj == NULL)
bfb1c796 2522 src = valaddr + offset;
d0a9e810 2523 else
bfb1c796 2524 src = value_contents (obj) + offset;
d0a9e810
JB
2525
2526 if (is_dynamic_type (type))
2527 {
2528 /* The length of TYPE might by dynamic, so we need to resolve
2529 TYPE in order to know its actual size, which we then use
2530 to create the contents buffer of the value we return.
2531 The difficulty is that the data containing our object is
2532 packed, and therefore maybe not at a byte boundary. So, what
2533 we do, is unpack the data into a byte-aligned buffer, and then
2534 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2535 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2536 staging.resize (staging_len);
d0a9e810
JB
2537
2538 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2539 staging.data (), staging.size (),
d0a9e810
JB
2540 is_big_endian, has_negatives (type),
2541 is_scalar);
d5722aa2 2542 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2543 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2544 {
2545 /* This happens when the length of the object is dynamic,
2546 and is actually smaller than the space reserved for it.
2547 For instance, in an array of variant records, the bit_size
2548 we're given is the array stride, which is constant and
2549 normally equal to the maximum size of its element.
2550 But, in reality, each element only actually spans a portion
2551 of that stride. */
2552 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2553 }
d0a9e810
JB
2554 }
2555
f93fca70
JB
2556 if (obj == NULL)
2557 {
2558 v = allocate_value (type);
bfb1c796 2559 src = valaddr + offset;
f93fca70
JB
2560 }
2561 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2562 {
0cafa88c 2563 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2564 gdb_byte *buf;
0cafa88c 2565
f93fca70 2566 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2567 buf = (gdb_byte *) alloca (src_len);
2568 read_memory (value_address (v), buf, src_len);
2569 src = buf;
f93fca70
JB
2570 }
2571 else
2572 {
2573 v = allocate_value (type);
bfb1c796 2574 src = value_contents (obj) + offset;
f93fca70
JB
2575 }
2576
2577 if (obj != NULL)
2578 {
2579 long new_offset = offset;
2580
2581 set_value_component_location (v, obj);
2582 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2583 set_value_bitsize (v, bit_size);
2584 if (value_bitpos (v) >= HOST_CHAR_BIT)
2585 {
2586 ++new_offset;
2587 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2588 }
2589 set_value_offset (v, new_offset);
2590
2591 /* Also set the parent value. This is needed when trying to
2592 assign a new value (in inferior memory). */
2593 set_value_parent (v, obj);
2594 }
2595 else
2596 set_value_bitsize (v, bit_size);
bfb1c796 2597 unpacked = value_contents_writeable (v);
f93fca70
JB
2598
2599 if (bit_size == 0)
2600 {
2601 memset (unpacked, 0, TYPE_LENGTH (type));
2602 return v;
2603 }
2604
d5722aa2 2605 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2606 {
d0a9e810
JB
2607 /* Small short-cut: If we've unpacked the data into a buffer
2608 of the same size as TYPE's length, then we can reuse that,
2609 instead of doing the unpacking again. */
d5722aa2 2610 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2611 }
d0a9e810
JB
2612 else
2613 ada_unpack_from_contents (src, bit_offset, bit_size,
2614 unpacked, TYPE_LENGTH (type),
2615 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2616
14f9c5c9
AS
2617 return v;
2618}
d2e4a39e 2619
14f9c5c9
AS
2620/* Store the contents of FROMVAL into the location of TOVAL.
2621 Return a new value with the location of TOVAL and contents of
2622 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2623 floating-point or non-scalar types. */
14f9c5c9 2624
d2e4a39e
AS
2625static struct value *
2626ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2627{
df407dfe
AC
2628 struct type *type = value_type (toval);
2629 int bits = value_bitsize (toval);
14f9c5c9 2630
52ce6436
PH
2631 toval = ada_coerce_ref (toval);
2632 fromval = ada_coerce_ref (fromval);
2633
2634 if (ada_is_direct_array_type (value_type (toval)))
2635 toval = ada_coerce_to_simple_array (toval);
2636 if (ada_is_direct_array_type (value_type (fromval)))
2637 fromval = ada_coerce_to_simple_array (fromval);
2638
88e3b34b 2639 if (!deprecated_value_modifiable (toval))
323e0a4a 2640 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2641
d2e4a39e 2642 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2643 && bits > 0
d2e4a39e 2644 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2645 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2646 {
df407dfe
AC
2647 int len = (value_bitpos (toval)
2648 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2649 int from_size;
224c3ddb 2650 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2651 struct value *val;
42ae5230 2652 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2653
2654 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2655 fromval = value_cast (type, fromval);
14f9c5c9 2656
52ce6436 2657 read_memory (to_addr, buffer, len);
aced2898
PH
2658 from_size = value_bitsize (fromval);
2659 if (from_size == 0)
2660 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
d48e62f4
TT
2661
2662 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2663 ULONGEST from_offset = 0;
2664 if (is_big_endian && is_scalar_type (value_type (fromval)))
2665 from_offset = from_size - bits;
2666 copy_bitwise (buffer, value_bitpos (toval),
2667 value_contents (fromval), from_offset,
2668 bits, is_big_endian);
972daa01 2669 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2670
14f9c5c9 2671 val = value_copy (toval);
0fd88904 2672 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2673 TYPE_LENGTH (type));
04624583 2674 deprecated_set_value_type (val, type);
d2e4a39e 2675
14f9c5c9
AS
2676 return val;
2677 }
2678
2679 return value_assign (toval, fromval);
2680}
2681
2682
7c512744
JB
2683/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2684 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2685 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2686 COMPONENT, and not the inferior's memory. The current contents
2687 of COMPONENT are ignored.
2688
2689 Although not part of the initial design, this function also works
2690 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2691 had a null address, and COMPONENT had an address which is equal to
2692 its offset inside CONTAINER. */
2693
52ce6436
PH
2694static void
2695value_assign_to_component (struct value *container, struct value *component,
2696 struct value *val)
2697{
2698 LONGEST offset_in_container =
42ae5230 2699 (LONGEST) (value_address (component) - value_address (container));
7c512744 2700 int bit_offset_in_container =
52ce6436
PH
2701 value_bitpos (component) - value_bitpos (container);
2702 int bits;
7c512744 2703
52ce6436
PH
2704 val = value_cast (value_type (component), val);
2705
2706 if (value_bitsize (component) == 0)
2707 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2708 else
2709 bits = value_bitsize (component);
2710
50810684 2711 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2a62dfa9
JB
2712 {
2713 int src_offset;
2714
2715 if (is_scalar_type (check_typedef (value_type (component))))
2716 src_offset
2717 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2718 else
2719 src_offset = 0;
a99bc3d2
JB
2720 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2721 value_bitpos (container) + bit_offset_in_container,
2722 value_contents (val), src_offset, bits, 1);
2a62dfa9 2723 }
52ce6436 2724 else
a99bc3d2
JB
2725 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2726 value_bitpos (container) + bit_offset_in_container,
2727 value_contents (val), 0, bits, 0);
7c512744
JB
2728}
2729
736ade86
XR
2730/* Determine if TYPE is an access to an unconstrained array. */
2731
d91e9ea8 2732bool
736ade86
XR
2733ada_is_access_to_unconstrained_array (struct type *type)
2734{
2735 return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
2736 && is_thick_pntr (ada_typedef_target_type (type)));
2737}
2738
4c4b4cd2
PH
2739/* The value of the element of array ARR at the ARITY indices given in IND.
2740 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2741 thereto. */
2742
d2e4a39e
AS
2743struct value *
2744ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2745{
2746 int k;
d2e4a39e
AS
2747 struct value *elt;
2748 struct type *elt_type;
14f9c5c9
AS
2749
2750 elt = ada_coerce_to_simple_array (arr);
2751
df407dfe 2752 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2753 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2754 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2755 return value_subscript_packed (elt, arity, ind);
2756
2757 for (k = 0; k < arity; k += 1)
2758 {
b9c50e9a
XR
2759 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2760
14f9c5c9 2761 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2762 error (_("too many subscripts (%d expected)"), k);
b9c50e9a 2763
2497b498 2764 elt = value_subscript (elt, pos_atr (ind[k]));
b9c50e9a
XR
2765
2766 if (ada_is_access_to_unconstrained_array (saved_elt_type)
2767 && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
2768 {
2769 /* The element is a typedef to an unconstrained array,
2770 except that the value_subscript call stripped the
2771 typedef layer. The typedef layer is GNAT's way to
2772 specify that the element is, at the source level, an
2773 access to the unconstrained array, rather than the
2774 unconstrained array. So, we need to restore that
2775 typedef layer, which we can do by forcing the element's
2776 type back to its original type. Otherwise, the returned
2777 value is going to be printed as the array, rather
2778 than as an access. Another symptom of the same issue
2779 would be that an expression trying to dereference the
2780 element would also be improperly rejected. */
2781 deprecated_set_value_type (elt, saved_elt_type);
2782 }
2783
2784 elt_type = ada_check_typedef (value_type (elt));
14f9c5c9 2785 }
b9c50e9a 2786
14f9c5c9
AS
2787 return elt;
2788}
2789
deede10c
JB
2790/* Assuming ARR is a pointer to a GDB array, the value of the element
2791 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2792 Does not read the entire array into memory.
2793
2794 Note: Unlike what one would expect, this function is used instead of
2795 ada_value_subscript for basically all non-packed array types. The reason
2796 for this is that a side effect of doing our own pointer arithmetics instead
2797 of relying on value_subscript is that there is no implicit typedef peeling.
2798 This is important for arrays of array accesses, where it allows us to
2799 preserve the fact that the array's element is an array access, where the
2800 access part os encoded in a typedef layer. */
14f9c5c9 2801
2c0b251b 2802static struct value *
deede10c 2803ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2804{
2805 int k;
919e6dbe 2806 struct value *array_ind = ada_value_ind (arr);
deede10c 2807 struct type *type
919e6dbe
PMR
2808 = check_typedef (value_enclosing_type (array_ind));
2809
2810 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2811 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2812 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2813
2814 for (k = 0; k < arity; k += 1)
2815 {
2816 LONGEST lwb, upb;
aa715135 2817 struct value *lwb_value;
14f9c5c9
AS
2818
2819 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2820 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2821 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2822 value_copy (arr));
14f9c5c9 2823 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2824 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2825 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2826 type = TYPE_TARGET_TYPE (type);
2827 }
2828
2829 return value_ind (arr);
2830}
2831
0b5d8877 2832/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2833 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2834 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2835 this array is LOW, as per Ada rules. */
0b5d8877 2836static struct value *
f5938064
JG
2837ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2838 int low, int high)
0b5d8877 2839{
b0dd7688 2840 struct type *type0 = ada_check_typedef (type);
aa715135 2841 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2842 struct type *index_type
aa715135 2843 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2844 struct type *slice_type = create_array_type_with_stride
2845 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2846 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2847 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2848 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2849 LONGEST base_low_pos, low_pos;
2850 CORE_ADDR base;
2851
2852 if (!discrete_position (base_index_type, low, &low_pos)
2853 || !discrete_position (base_index_type, base_low, &base_low_pos))
2854 {
2855 warning (_("unable to get positions in slice, use bounds instead"));
2856 low_pos = low;
2857 base_low_pos = base_low;
2858 }
5b4ee69b 2859
aa715135
JG
2860 base = value_as_address (array_ptr)
2861 + ((low_pos - base_low_pos)
2862 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2863 return value_at_lazy (slice_type, base);
0b5d8877
PH
2864}
2865
2866
2867static struct value *
2868ada_value_slice (struct value *array, int low, int high)
2869{
b0dd7688 2870 struct type *type = ada_check_typedef (value_type (array));
aa715135 2871 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2872 struct type *index_type
2873 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2874 struct type *slice_type = create_array_type_with_stride
2875 (NULL, TYPE_TARGET_TYPE (type), index_type,
2876 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2877 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2878 LONGEST low_pos, high_pos;
5b4ee69b 2879
aa715135
JG
2880 if (!discrete_position (base_index_type, low, &low_pos)
2881 || !discrete_position (base_index_type, high, &high_pos))
2882 {
2883 warning (_("unable to get positions in slice, use bounds instead"));
2884 low_pos = low;
2885 high_pos = high;
2886 }
2887
2888 return value_cast (slice_type,
2889 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2890}
2891
14f9c5c9
AS
2892/* If type is a record type in the form of a standard GNAT array
2893 descriptor, returns the number of dimensions for type. If arr is a
2894 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2895 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2896
2897int
d2e4a39e 2898ada_array_arity (struct type *type)
14f9c5c9
AS
2899{
2900 int arity;
2901
2902 if (type == NULL)
2903 return 0;
2904
2905 type = desc_base_type (type);
2906
2907 arity = 0;
d2e4a39e 2908 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2909 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2910 else
2911 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2912 {
4c4b4cd2 2913 arity += 1;
61ee279c 2914 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2915 }
d2e4a39e 2916
14f9c5c9
AS
2917 return arity;
2918}
2919
2920/* If TYPE is a record type in the form of a standard GNAT array
2921 descriptor or a simple array type, returns the element type for
2922 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2923 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2924
d2e4a39e
AS
2925struct type *
2926ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2927{
2928 type = desc_base_type (type);
2929
d2e4a39e 2930 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2931 {
2932 int k;
d2e4a39e 2933 struct type *p_array_type;
14f9c5c9 2934
556bdfd4 2935 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2936
2937 k = ada_array_arity (type);
2938 if (k == 0)
4c4b4cd2 2939 return NULL;
d2e4a39e 2940
4c4b4cd2 2941 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2942 if (nindices >= 0 && k > nindices)
4c4b4cd2 2943 k = nindices;
d2e4a39e 2944 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2945 {
61ee279c 2946 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2947 k -= 1;
2948 }
14f9c5c9
AS
2949 return p_array_type;
2950 }
2951 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2952 {
2953 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2954 {
2955 type = TYPE_TARGET_TYPE (type);
2956 nindices -= 1;
2957 }
14f9c5c9
AS
2958 return type;
2959 }
2960
2961 return NULL;
2962}
2963
4c4b4cd2 2964/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2965 Does not examine memory. Throws an error if N is invalid or TYPE
2966 is not an array type. NAME is the name of the Ada attribute being
2967 evaluated ('range, 'first, 'last, or 'length); it is used in building
2968 the error message. */
14f9c5c9 2969
1eea4ebd
UW
2970static struct type *
2971ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2972{
4c4b4cd2
PH
2973 struct type *result_type;
2974
14f9c5c9
AS
2975 type = desc_base_type (type);
2976
1eea4ebd
UW
2977 if (n < 0 || n > ada_array_arity (type))
2978 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2979
4c4b4cd2 2980 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2981 {
2982 int i;
2983
2984 for (i = 1; i < n; i += 1)
4c4b4cd2 2985 type = TYPE_TARGET_TYPE (type);
262452ec 2986 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2987 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2988 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2989 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2990 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2991 result_type = NULL;
14f9c5c9 2992 }
d2e4a39e 2993 else
1eea4ebd
UW
2994 {
2995 result_type = desc_index_type (desc_bounds_type (type), n);
2996 if (result_type == NULL)
2997 error (_("attempt to take bound of something that is not an array"));
2998 }
2999
3000 return result_type;
14f9c5c9
AS
3001}
3002
3003/* Given that arr is an array type, returns the lower bound of the
3004 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3005 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3006 array-descriptor type. It works for other arrays with bounds supplied
3007 by run-time quantities other than discriminants. */
14f9c5c9 3008
abb68b3e 3009static LONGEST
fb5e3d5c 3010ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3011{
8a48ac95 3012 struct type *type, *index_type_desc, *index_type;
1ce677a4 3013 int i;
262452ec
JK
3014
3015 gdb_assert (which == 0 || which == 1);
14f9c5c9 3016
ad82864c
JB
3017 if (ada_is_constrained_packed_array_type (arr_type))
3018 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3019
4c4b4cd2 3020 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3021 return (LONGEST) - which;
14f9c5c9
AS
3022
3023 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3024 type = TYPE_TARGET_TYPE (arr_type);
3025 else
3026 type = arr_type;
3027
bafffb51
JB
3028 if (TYPE_FIXED_INSTANCE (type))
3029 {
3030 /* The array has already been fixed, so we do not need to
3031 check the parallel ___XA type again. That encoding has
3032 already been applied, so ignore it now. */
3033 index_type_desc = NULL;
3034 }
3035 else
3036 {
3037 index_type_desc = ada_find_parallel_type (type, "___XA");
3038 ada_fixup_array_indexes_type (index_type_desc);
3039 }
3040
262452ec 3041 if (index_type_desc != NULL)
28c85d6c
JB
3042 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3043 NULL);
262452ec 3044 else
8a48ac95
JB
3045 {
3046 struct type *elt_type = check_typedef (type);
3047
3048 for (i = 1; i < n; i++)
3049 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3050
3051 index_type = TYPE_INDEX_TYPE (elt_type);
3052 }
262452ec 3053
43bbcdc2
PH
3054 return
3055 (LONGEST) (which == 0
3056 ? ada_discrete_type_low_bound (index_type)
3057 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3058}
3059
3060/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3061 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3062 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3063 supplied by run-time quantities other than discriminants. */
14f9c5c9 3064
1eea4ebd 3065static LONGEST
4dc81987 3066ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3067{
eb479039
JB
3068 struct type *arr_type;
3069
3070 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3071 arr = value_ind (arr);
3072 arr_type = value_enclosing_type (arr);
14f9c5c9 3073
ad82864c
JB
3074 if (ada_is_constrained_packed_array_type (arr_type))
3075 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3076 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3077 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3078 else
1eea4ebd 3079 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3080}
3081
3082/* Given that arr is an array value, returns the length of the
3083 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3084 supplied by run-time quantities other than discriminants.
3085 Does not work for arrays indexed by enumeration types with representation
3086 clauses at the moment. */
14f9c5c9 3087
1eea4ebd 3088static LONGEST
d2e4a39e 3089ada_array_length (struct value *arr, int n)
14f9c5c9 3090{
aa715135
JG
3091 struct type *arr_type, *index_type;
3092 int low, high;
eb479039
JB
3093
3094 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3095 arr = value_ind (arr);
3096 arr_type = value_enclosing_type (arr);
14f9c5c9 3097
ad82864c
JB
3098 if (ada_is_constrained_packed_array_type (arr_type))
3099 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3100
4c4b4cd2 3101 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3102 {
3103 low = ada_array_bound_from_type (arr_type, n, 0);
3104 high = ada_array_bound_from_type (arr_type, n, 1);
3105 }
14f9c5c9 3106 else
aa715135
JG
3107 {
3108 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3109 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3110 }
3111
f168693b 3112 arr_type = check_typedef (arr_type);
7150d33c 3113 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3114 if (index_type != NULL)
3115 {
3116 struct type *base_type;
3117 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3118 base_type = TYPE_TARGET_TYPE (index_type);
3119 else
3120 base_type = index_type;
3121
3122 low = pos_atr (value_from_longest (base_type, low));
3123 high = pos_atr (value_from_longest (base_type, high));
3124 }
3125 return high - low + 1;
4c4b4cd2
PH
3126}
3127
bff8c71f
TT
3128/* An array whose type is that of ARR_TYPE (an array type), with
3129 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3130 less than LOW, then LOW-1 is used. */
4c4b4cd2
PH
3131
3132static struct value *
bff8c71f 3133empty_array (struct type *arr_type, int low, int high)
4c4b4cd2 3134{
b0dd7688 3135 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3136 struct type *index_type
3137 = create_static_range_type
bff8c71f
TT
3138 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low,
3139 high < low ? low - 1 : high);
b0dd7688 3140 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3141
0b5d8877 3142 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3143}
14f9c5c9 3144\f
d2e4a39e 3145
4c4b4cd2 3146 /* Name resolution */
14f9c5c9 3147
4c4b4cd2
PH
3148/* The "decoded" name for the user-definable Ada operator corresponding
3149 to OP. */
14f9c5c9 3150
d2e4a39e 3151static const char *
4c4b4cd2 3152ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3153{
3154 int i;
3155
4c4b4cd2 3156 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3157 {
3158 if (ada_opname_table[i].op == op)
4c4b4cd2 3159 return ada_opname_table[i].decoded;
14f9c5c9 3160 }
323e0a4a 3161 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3162}
3163
3164
4c4b4cd2
PH
3165/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3166 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3167 undefined namespace) and converts operators that are
3168 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3169 non-null, it provides a preferred result type [at the moment, only
3170 type void has any effect---causing procedures to be preferred over
3171 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3172 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3173
4c4b4cd2 3174static void
699bd4cf
TT
3175resolve (expression_up *expp, int void_context_p, int parse_completion,
3176 innermost_block_tracker *tracker)
14f9c5c9 3177{
30b15541
UW
3178 struct type *context_type = NULL;
3179 int pc = 0;
3180
3181 if (void_context_p)
3182 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3183
699bd4cf 3184 resolve_subexp (expp, &pc, 1, context_type, parse_completion, tracker);
14f9c5c9
AS
3185}
3186
4c4b4cd2
PH
3187/* Resolve the operator of the subexpression beginning at
3188 position *POS of *EXPP. "Resolving" consists of replacing
3189 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3190 with their resolutions, replacing built-in operators with
3191 function calls to user-defined operators, where appropriate, and,
3192 when DEPROCEDURE_P is non-zero, converting function-valued variables
3193 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3194 are as in ada_resolve, above. */
14f9c5c9 3195
d2e4a39e 3196static struct value *
e9d9f57e 3197resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
699bd4cf
TT
3198 struct type *context_type, int parse_completion,
3199 innermost_block_tracker *tracker)
14f9c5c9
AS
3200{
3201 int pc = *pos;
3202 int i;
4c4b4cd2 3203 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3204 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3205 struct value **argvec; /* Vector of operand types (alloca'ed). */
3206 int nargs; /* Number of operands. */
52ce6436 3207 int oplen;
14f9c5c9
AS
3208
3209 argvec = NULL;
3210 nargs = 0;
e9d9f57e 3211 exp = expp->get ();
14f9c5c9 3212
52ce6436
PH
3213 /* Pass one: resolve operands, saving their types and updating *pos,
3214 if needed. */
14f9c5c9
AS
3215 switch (op)
3216 {
4c4b4cd2
PH
3217 case OP_FUNCALL:
3218 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3219 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3220 *pos += 7;
4c4b4cd2
PH
3221 else
3222 {
3223 *pos += 3;
699bd4cf 3224 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
4c4b4cd2
PH
3225 }
3226 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3227 break;
3228
14f9c5c9 3229 case UNOP_ADDR:
4c4b4cd2 3230 *pos += 1;
699bd4cf 3231 resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
4c4b4cd2
PH
3232 break;
3233
52ce6436
PH
3234 case UNOP_QUAL:
3235 *pos += 3;
2a612529 3236 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type),
699bd4cf 3237 parse_completion, tracker);
4c4b4cd2
PH
3238 break;
3239
52ce6436 3240 case OP_ATR_MODULUS:
4c4b4cd2
PH
3241 case OP_ATR_SIZE:
3242 case OP_ATR_TAG:
4c4b4cd2
PH
3243 case OP_ATR_FIRST:
3244 case OP_ATR_LAST:
3245 case OP_ATR_LENGTH:
3246 case OP_ATR_POS:
3247 case OP_ATR_VAL:
4c4b4cd2
PH
3248 case OP_ATR_MIN:
3249 case OP_ATR_MAX:
52ce6436
PH
3250 case TERNOP_IN_RANGE:
3251 case BINOP_IN_BOUNDS:
3252 case UNOP_IN_RANGE:
3253 case OP_AGGREGATE:
3254 case OP_OTHERS:
3255 case OP_CHOICES:
3256 case OP_POSITIONAL:
3257 case OP_DISCRETE_RANGE:
3258 case OP_NAME:
3259 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3260 *pos += oplen;
14f9c5c9
AS
3261 break;
3262
3263 case BINOP_ASSIGN:
3264 {
4c4b4cd2
PH
3265 struct value *arg1;
3266
3267 *pos += 1;
699bd4cf 3268 arg1 = resolve_subexp (expp, pos, 0, NULL, parse_completion, tracker);
4c4b4cd2 3269 if (arg1 == NULL)
699bd4cf 3270 resolve_subexp (expp, pos, 1, NULL, parse_completion, tracker);
4c4b4cd2 3271 else
699bd4cf
TT
3272 resolve_subexp (expp, pos, 1, value_type (arg1), parse_completion,
3273 tracker);
4c4b4cd2 3274 break;
14f9c5c9
AS
3275 }
3276
4c4b4cd2 3277 case UNOP_CAST:
4c4b4cd2
PH
3278 *pos += 3;
3279 nargs = 1;
3280 break;
14f9c5c9 3281
4c4b4cd2
PH
3282 case BINOP_ADD:
3283 case BINOP_SUB:
3284 case BINOP_MUL:
3285 case BINOP_DIV:
3286 case BINOP_REM:
3287 case BINOP_MOD:
3288 case BINOP_EXP:
3289 case BINOP_CONCAT:
3290 case BINOP_LOGICAL_AND:
3291 case BINOP_LOGICAL_OR:
3292 case BINOP_BITWISE_AND:
3293 case BINOP_BITWISE_IOR:
3294 case BINOP_BITWISE_XOR:
14f9c5c9 3295
4c4b4cd2
PH
3296 case BINOP_EQUAL:
3297 case BINOP_NOTEQUAL:
3298 case BINOP_LESS:
3299 case BINOP_GTR:
3300 case BINOP_LEQ:
3301 case BINOP_GEQ:
14f9c5c9 3302
4c4b4cd2
PH
3303 case BINOP_REPEAT:
3304 case BINOP_SUBSCRIPT:
3305 case BINOP_COMMA:
40c8aaa9
JB
3306 *pos += 1;
3307 nargs = 2;
3308 break;
14f9c5c9 3309
4c4b4cd2
PH
3310 case UNOP_NEG:
3311 case UNOP_PLUS:
3312 case UNOP_LOGICAL_NOT:
3313 case UNOP_ABS:
3314 case UNOP_IND:
3315 *pos += 1;
3316 nargs = 1;
3317 break;
14f9c5c9 3318
4c4b4cd2 3319 case OP_LONG:
edd079d9 3320 case OP_FLOAT:
4c4b4cd2 3321 case OP_VAR_VALUE:
74ea4be4 3322 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3323 *pos += 4;
3324 break;
14f9c5c9 3325
4c4b4cd2
PH
3326 case OP_TYPE:
3327 case OP_BOOL:
3328 case OP_LAST:
4c4b4cd2
PH
3329 case OP_INTERNALVAR:
3330 *pos += 3;
3331 break;
14f9c5c9 3332
4c4b4cd2
PH
3333 case UNOP_MEMVAL:
3334 *pos += 3;
3335 nargs = 1;
3336 break;
3337
67f3407f
DJ
3338 case OP_REGISTER:
3339 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3340 break;
3341
4c4b4cd2
PH
3342 case STRUCTOP_STRUCT:
3343 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3344 nargs = 1;
3345 break;
3346
4c4b4cd2 3347 case TERNOP_SLICE:
4c4b4cd2
PH
3348 *pos += 1;
3349 nargs = 3;
3350 break;
3351
52ce6436 3352 case OP_STRING:
14f9c5c9 3353 break;
4c4b4cd2
PH
3354
3355 default:
323e0a4a 3356 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3357 }
3358
8d749320 3359 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2 3360 for (i = 0; i < nargs; i += 1)
699bd4cf
TT
3361 argvec[i] = resolve_subexp (expp, pos, 1, NULL, parse_completion,
3362 tracker);
4c4b4cd2 3363 argvec[i] = NULL;
e9d9f57e 3364 exp = expp->get ();
4c4b4cd2
PH
3365
3366 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3367 switch (op)
3368 {
3369 default:
3370 break;
3371
14f9c5c9 3372 case OP_VAR_VALUE:
4c4b4cd2 3373 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3374 {
54d343a2 3375 std::vector<struct block_symbol> candidates;
76a01679
JB
3376 int n_candidates;
3377
3378 n_candidates =
3379 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3380 (exp->elts[pc + 2].symbol),
3381 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3382 &candidates);
76a01679
JB
3383
3384 if (n_candidates > 1)
3385 {
3386 /* Types tend to get re-introduced locally, so if there
3387 are any local symbols that are not types, first filter
3388 out all types. */
3389 int j;
3390 for (j = 0; j < n_candidates; j += 1)
d12307c1 3391 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3392 {
3393 case LOC_REGISTER:
3394 case LOC_ARG:
3395 case LOC_REF_ARG:
76a01679
JB
3396 case LOC_REGPARM_ADDR:
3397 case LOC_LOCAL:
76a01679 3398 case LOC_COMPUTED:
76a01679
JB
3399 goto FoundNonType;
3400 default:
3401 break;
3402 }
3403 FoundNonType:
3404 if (j < n_candidates)
3405 {
3406 j = 0;
3407 while (j < n_candidates)
3408 {
d12307c1 3409 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3410 {
3411 candidates[j] = candidates[n_candidates - 1];
3412 n_candidates -= 1;
3413 }
3414 else
3415 j += 1;
3416 }
3417 }
3418 }
3419
3420 if (n_candidates == 0)
323e0a4a 3421 error (_("No definition found for %s"),
76a01679
JB
3422 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3423 else if (n_candidates == 1)
3424 i = 0;
3425 else if (deprocedure_p
54d343a2 3426 && !is_nonfunction (candidates.data (), n_candidates))
76a01679 3427 {
06d5cf63 3428 i = ada_resolve_function
54d343a2 3429 (candidates.data (), n_candidates, NULL, 0,
06d5cf63 3430 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2a612529 3431 context_type, parse_completion);
76a01679 3432 if (i < 0)
323e0a4a 3433 error (_("Could not find a match for %s"),
76a01679
JB
3434 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3435 }
3436 else
3437 {
323e0a4a 3438 printf_filtered (_("Multiple matches for %s\n"),
76a01679 3439 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
54d343a2 3440 user_select_syms (candidates.data (), n_candidates, 1);
76a01679
JB
3441 i = 0;
3442 }
3443
3444 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3445 exp->elts[pc + 2].symbol = candidates[i].symbol;
699bd4cf 3446 tracker->update (candidates[i]);
76a01679
JB
3447 }
3448
3449 if (deprocedure_p
3450 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3451 == TYPE_CODE_FUNC))
3452 {
424da6cf 3453 replace_operator_with_call (expp, pc, 0, 4,
76a01679
JB
3454 exp->elts[pc + 2].symbol,
3455 exp->elts[pc + 1].block);
e9d9f57e 3456 exp = expp->get ();
76a01679 3457 }
14f9c5c9
AS
3458 break;
3459
3460 case OP_FUNCALL:
3461 {
4c4b4cd2 3462 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3463 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3464 {
54d343a2 3465 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3466 int n_candidates;
3467
3468 n_candidates =
76a01679
JB
3469 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3470 (exp->elts[pc + 5].symbol),
3471 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3472 &candidates);
ec6a20c2 3473
4c4b4cd2
PH
3474 if (n_candidates == 1)
3475 i = 0;
3476 else
3477 {
06d5cf63 3478 i = ada_resolve_function
54d343a2 3479 (candidates.data (), n_candidates,
06d5cf63
JB
3480 argvec, nargs,
3481 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2a612529 3482 context_type, parse_completion);
4c4b4cd2 3483 if (i < 0)
323e0a4a 3484 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3485 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3486 }
3487
3488 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3489 exp->elts[pc + 5].symbol = candidates[i].symbol;
699bd4cf 3490 tracker->update (candidates[i]);
4c4b4cd2 3491 }
14f9c5c9
AS
3492 }
3493 break;
3494 case BINOP_ADD:
3495 case BINOP_SUB:
3496 case BINOP_MUL:
3497 case BINOP_DIV:
3498 case BINOP_REM:
3499 case BINOP_MOD:
3500 case BINOP_CONCAT:
3501 case BINOP_BITWISE_AND:
3502 case BINOP_BITWISE_IOR:
3503 case BINOP_BITWISE_XOR:
3504 case BINOP_EQUAL:
3505 case BINOP_NOTEQUAL:
3506 case BINOP_LESS:
3507 case BINOP_GTR:
3508 case BINOP_LEQ:
3509 case BINOP_GEQ:
3510 case BINOP_EXP:
3511 case UNOP_NEG:
3512 case UNOP_PLUS:
3513 case UNOP_LOGICAL_NOT:
3514 case UNOP_ABS:
3515 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3516 {
54d343a2 3517 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3518 int n_candidates;
3519
3520 n_candidates =
b5ec771e 3521 ada_lookup_symbol_list (ada_decoded_op_name (op),
582942f4 3522 NULL, VAR_DOMAIN,
4eeaa230 3523 &candidates);
ec6a20c2 3524
54d343a2 3525 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
2a612529
TT
3526 nargs, ada_decoded_op_name (op), NULL,
3527 parse_completion);
4c4b4cd2
PH
3528 if (i < 0)
3529 break;
3530
d12307c1
PMR
3531 replace_operator_with_call (expp, pc, nargs, 1,
3532 candidates[i].symbol,
3533 candidates[i].block);
e9d9f57e 3534 exp = expp->get ();
4c4b4cd2 3535 }
14f9c5c9 3536 break;
4c4b4cd2
PH
3537
3538 case OP_TYPE:
b3dbf008 3539 case OP_REGISTER:
4c4b4cd2 3540 return NULL;
14f9c5c9
AS
3541 }
3542
3543 *pos = pc;
ced9779b
JB
3544 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3545 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3546 exp->elts[pc + 1].objfile,
3547 exp->elts[pc + 2].msymbol);
3548 else
3549 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3550}
3551
3552/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3553 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3554 a non-pointer. */
14f9c5c9 3555/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3556 liberal. */
14f9c5c9
AS
3557
3558static int
4dc81987 3559ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3560{
61ee279c
PH
3561 ftype = ada_check_typedef (ftype);
3562 atype = ada_check_typedef (atype);
14f9c5c9
AS
3563
3564 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3565 ftype = TYPE_TARGET_TYPE (ftype);
3566 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3567 atype = TYPE_TARGET_TYPE (atype);
3568
d2e4a39e 3569 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3570 {
3571 default:
5b3d5b7d 3572 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3573 case TYPE_CODE_PTR:
3574 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3575 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3576 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3577 else
1265e4aa
JB
3578 return (may_deref
3579 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3580 case TYPE_CODE_INT:
3581 case TYPE_CODE_ENUM:
3582 case TYPE_CODE_RANGE:
3583 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3584 {
3585 case TYPE_CODE_INT:
3586 case TYPE_CODE_ENUM:
3587 case TYPE_CODE_RANGE:
3588 return 1;
3589 default:
3590 return 0;
3591 }
14f9c5c9
AS
3592
3593 case TYPE_CODE_ARRAY:
d2e4a39e 3594 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3595 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3596
3597 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3598 if (ada_is_array_descriptor_type (ftype))
3599 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3600 || ada_is_array_descriptor_type (atype));
14f9c5c9 3601 else
4c4b4cd2
PH
3602 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3603 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3604
3605 case TYPE_CODE_UNION:
3606 case TYPE_CODE_FLT:
3607 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3608 }
3609}
3610
3611/* Return non-zero if the formals of FUNC "sufficiently match" the
3612 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3613 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3614 argument function. */
14f9c5c9
AS
3615
3616static int
d2e4a39e 3617ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3618{
3619 int i;
d2e4a39e 3620 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3621
1265e4aa
JB
3622 if (SYMBOL_CLASS (func) == LOC_CONST
3623 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3624 return (n_actuals == 0);
3625 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3626 return 0;
3627
3628 if (TYPE_NFIELDS (func_type) != n_actuals)
3629 return 0;
3630
3631 for (i = 0; i < n_actuals; i += 1)
3632 {
4c4b4cd2 3633 if (actuals[i] == NULL)
76a01679
JB
3634 return 0;
3635 else
3636 {
5b4ee69b
MS
3637 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3638 i));
df407dfe 3639 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3640
76a01679
JB
3641 if (!ada_type_match (ftype, atype, 1))
3642 return 0;
3643 }
14f9c5c9
AS
3644 }
3645 return 1;
3646}
3647
3648/* False iff function type FUNC_TYPE definitely does not produce a value
3649 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3650 FUNC_TYPE is not a valid function type with a non-null return type
3651 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3652
3653static int
d2e4a39e 3654return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3655{
d2e4a39e 3656 struct type *return_type;
14f9c5c9
AS
3657
3658 if (func_type == NULL)
3659 return 1;
3660
4c4b4cd2 3661 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3662 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3663 else
18af8284 3664 return_type = get_base_type (func_type);
14f9c5c9
AS
3665 if (return_type == NULL)
3666 return 1;
3667
18af8284 3668 context_type = get_base_type (context_type);
14f9c5c9
AS
3669
3670 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3671 return context_type == NULL || return_type == context_type;
3672 else if (context_type == NULL)
3673 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3674 else
3675 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3676}
3677
3678
4c4b4cd2 3679/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3680 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3681 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3682 that returns that type, then eliminate matches that don't. If
3683 CONTEXT_TYPE is void and there is at least one match that does not
3684 return void, eliminate all matches that do.
3685
14f9c5c9
AS
3686 Asks the user if there is more than one match remaining. Returns -1
3687 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3688 solely for messages. May re-arrange and modify SYMS in
3689 the process; the index returned is for the modified vector. */
14f9c5c9 3690
4c4b4cd2 3691static int
d12307c1 3692ada_resolve_function (struct block_symbol syms[],
4c4b4cd2 3693 int nsyms, struct value **args, int nargs,
2a612529
TT
3694 const char *name, struct type *context_type,
3695 int parse_completion)
14f9c5c9 3696{
30b15541 3697 int fallback;
14f9c5c9 3698 int k;
4c4b4cd2 3699 int m; /* Number of hits */
14f9c5c9 3700
d2e4a39e 3701 m = 0;
30b15541
UW
3702 /* In the first pass of the loop, we only accept functions matching
3703 context_type. If none are found, we add a second pass of the loop
3704 where every function is accepted. */
3705 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3706 {
3707 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3708 {
d12307c1 3709 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3710
d12307c1 3711 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3712 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3713 {
3714 syms[m] = syms[k];
3715 m += 1;
3716 }
3717 }
14f9c5c9
AS
3718 }
3719
dc5c8746
PMR
3720 /* If we got multiple matches, ask the user which one to use. Don't do this
3721 interactive thing during completion, though, as the purpose of the
3722 completion is providing a list of all possible matches. Prompting the
3723 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3724 if (m == 0)
3725 return -1;
dc5c8746 3726 else if (m > 1 && !parse_completion)
14f9c5c9 3727 {
323e0a4a 3728 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3729 user_select_syms (syms, m, 1);
14f9c5c9
AS
3730 return 0;
3731 }
3732 return 0;
3733}
3734
4c4b4cd2
PH
3735/* Returns true (non-zero) iff decoded name N0 should appear before N1
3736 in a listing of choices during disambiguation (see sort_choices, below).
3737 The idea is that overloadings of a subprogram name from the
3738 same package should sort in their source order. We settle for ordering
3739 such symbols by their trailing number (__N or $N). */
3740
14f9c5c9 3741static int
0d5cff50 3742encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3743{
3744 if (N1 == NULL)
3745 return 0;
3746 else if (N0 == NULL)
3747 return 1;
3748 else
3749 {
3750 int k0, k1;
5b4ee69b 3751
d2e4a39e 3752 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3753 ;
d2e4a39e 3754 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3755 ;
d2e4a39e 3756 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3757 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3758 {
3759 int n0, n1;
5b4ee69b 3760
4c4b4cd2
PH
3761 n0 = k0;
3762 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3763 n0 -= 1;
3764 n1 = k1;
3765 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3766 n1 -= 1;
3767 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3768 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3769 }
14f9c5c9
AS
3770 return (strcmp (N0, N1) < 0);
3771 }
3772}
d2e4a39e 3773
4c4b4cd2
PH
3774/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3775 encoded names. */
3776
d2e4a39e 3777static void
d12307c1 3778sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3779{
4c4b4cd2 3780 int i;
5b4ee69b 3781
d2e4a39e 3782 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3783 {
d12307c1 3784 struct block_symbol sym = syms[i];
14f9c5c9
AS
3785 int j;
3786
d2e4a39e 3787 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3788 {
d12307c1
PMR
3789 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3790 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3791 break;
3792 syms[j + 1] = syms[j];
3793 }
d2e4a39e 3794 syms[j + 1] = sym;
14f9c5c9
AS
3795 }
3796}
3797
d72413e6
PMR
3798/* Whether GDB should display formals and return types for functions in the
3799 overloads selection menu. */
3800static int print_signatures = 1;
3801
3802/* Print the signature for SYM on STREAM according to the FLAGS options. For
3803 all but functions, the signature is just the name of the symbol. For
3804 functions, this is the name of the function, the list of types for formals
3805 and the return type (if any). */
3806
3807static void
3808ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3809 const struct type_print_options *flags)
3810{
3811 struct type *type = SYMBOL_TYPE (sym);
3812
3813 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3814 if (!print_signatures
3815 || type == NULL
3816 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3817 return;
3818
3819 if (TYPE_NFIELDS (type) > 0)
3820 {
3821 int i;
3822
3823 fprintf_filtered (stream, " (");
3824 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3825 {
3826 if (i > 0)
3827 fprintf_filtered (stream, "; ");
3828 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3829 flags);
3830 }
3831 fprintf_filtered (stream, ")");
3832 }
3833 if (TYPE_TARGET_TYPE (type) != NULL
3834 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3835 {
3836 fprintf_filtered (stream, " return ");
3837 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3838 }
3839}
3840
4c4b4cd2
PH
3841/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3842 by asking the user (if necessary), returning the number selected,
3843 and setting the first elements of SYMS items. Error if no symbols
3844 selected. */
14f9c5c9
AS
3845
3846/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3847 to be re-integrated one of these days. */
14f9c5c9
AS
3848
3849int
d12307c1 3850user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3851{
3852 int i;
8d749320 3853 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3854 int n_chosen;
3855 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3856 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3857
3858 if (max_results < 1)
323e0a4a 3859 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3860 if (nsyms <= 1)
3861 return nsyms;
3862
717d2f5a
JB
3863 if (select_mode == multiple_symbols_cancel)
3864 error (_("\
3865canceled because the command is ambiguous\n\
3866See set/show multiple-symbol."));
a0087920 3867
717d2f5a
JB
3868 /* If select_mode is "all", then return all possible symbols.
3869 Only do that if more than one symbol can be selected, of course.
3870 Otherwise, display the menu as usual. */
3871 if (select_mode == multiple_symbols_all && max_results > 1)
3872 return nsyms;
3873
a0087920 3874 printf_filtered (_("[0] cancel\n"));
14f9c5c9 3875 if (max_results > 1)
a0087920 3876 printf_filtered (_("[1] all\n"));
14f9c5c9 3877
4c4b4cd2 3878 sort_choices (syms, nsyms);
14f9c5c9
AS
3879
3880 for (i = 0; i < nsyms; i += 1)
3881 {
d12307c1 3882 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3883 continue;
3884
d12307c1 3885 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3886 {
76a01679 3887 struct symtab_and_line sal =
d12307c1 3888 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3889
a0087920 3890 printf_filtered ("[%d] ", i + first_choice);
d72413e6
PMR
3891 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3892 &type_print_raw_options);
323e0a4a 3893 if (sal.symtab == NULL)
a0087920
TT
3894 printf_filtered (_(" at <no source file available>:%d\n"),
3895 sal.line);
323e0a4a 3896 else
a0087920
TT
3897 printf_filtered (_(" at %s:%d\n"),
3898 symtab_to_filename_for_display (sal.symtab),
3899 sal.line);
4c4b4cd2
PH
3900 continue;
3901 }
d2e4a39e 3902 else
4c4b4cd2
PH
3903 {
3904 int is_enumeral =
d12307c1
PMR
3905 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3906 && SYMBOL_TYPE (syms[i].symbol) != NULL
3907 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3908 struct symtab *symtab = NULL;
3909
d12307c1
PMR
3910 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3911 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3912
d12307c1 3913 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6 3914 {
a0087920 3915 printf_filtered ("[%d] ", i + first_choice);
d72413e6
PMR
3916 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3917 &type_print_raw_options);
a0087920
TT
3918 printf_filtered (_(" at %s:%d\n"),
3919 symtab_to_filename_for_display (symtab),
3920 SYMBOL_LINE (syms[i].symbol));
d72413e6 3921 }
76a01679 3922 else if (is_enumeral
d12307c1 3923 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3924 {
a0087920 3925 printf_filtered (("[%d] "), i + first_choice);
d12307c1 3926 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3927 gdb_stdout, -1, 0, &type_print_raw_options);
a0087920
TT
3928 printf_filtered (_("'(%s) (enumeral)\n"),
3929 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3930 }
d72413e6
PMR
3931 else
3932 {
a0087920 3933 printf_filtered ("[%d] ", i + first_choice);
d72413e6
PMR
3934 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3935 &type_print_raw_options);
3936
3937 if (symtab != NULL)
a0087920
TT
3938 printf_filtered (is_enumeral
3939 ? _(" in %s (enumeral)\n")
3940 : _(" at %s:?\n"),
3941 symtab_to_filename_for_display (symtab));
d72413e6 3942 else
a0087920
TT
3943 printf_filtered (is_enumeral
3944 ? _(" (enumeral)\n")
3945 : _(" at ?\n"));
d72413e6 3946 }
4c4b4cd2 3947 }
14f9c5c9 3948 }
d2e4a39e 3949
14f9c5c9 3950 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3951 "overload-choice");
14f9c5c9
AS
3952
3953 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3954 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3955
3956 return n_chosen;
3957}
3958
3959/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3960 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3961 order in CHOICES[0 .. N-1], and return N.
3962
3963 The user types choices as a sequence of numbers on one line
3964 separated by blanks, encoding them as follows:
3965
4c4b4cd2 3966 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3967 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3968 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3969
4c4b4cd2 3970 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3971
3972 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3973 prompts (for use with the -f switch). */
14f9c5c9
AS
3974
3975int
d2e4a39e 3976get_selections (int *choices, int n_choices, int max_results,
a121b7c1 3977 int is_all_choice, const char *annotation_suffix)
14f9c5c9 3978{
d2e4a39e 3979 char *args;
a121b7c1 3980 const char *prompt;
14f9c5c9
AS
3981 int n_chosen;
3982 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3983
14f9c5c9
AS
3984 prompt = getenv ("PS2");
3985 if (prompt == NULL)
0bcd0149 3986 prompt = "> ";
14f9c5c9 3987
89fbedf3 3988 args = command_line_input (prompt, annotation_suffix);
d2e4a39e 3989
14f9c5c9 3990 if (args == NULL)
323e0a4a 3991 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3992
3993 n_chosen = 0;
76a01679 3994
4c4b4cd2
PH
3995 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3996 order, as given in args. Choices are validated. */
14f9c5c9
AS
3997 while (1)
3998 {
d2e4a39e 3999 char *args2;
14f9c5c9
AS
4000 int choice, j;
4001
0fcd72ba 4002 args = skip_spaces (args);
14f9c5c9 4003 if (*args == '\0' && n_chosen == 0)
323e0a4a 4004 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4005 else if (*args == '\0')
4c4b4cd2 4006 break;
14f9c5c9
AS
4007
4008 choice = strtol (args, &args2, 10);
d2e4a39e 4009 if (args == args2 || choice < 0
4c4b4cd2 4010 || choice > n_choices + first_choice - 1)
323e0a4a 4011 error (_("Argument must be choice number"));
14f9c5c9
AS
4012 args = args2;
4013
d2e4a39e 4014 if (choice == 0)
323e0a4a 4015 error (_("cancelled"));
14f9c5c9
AS
4016
4017 if (choice < first_choice)
4c4b4cd2
PH
4018 {
4019 n_chosen = n_choices;
4020 for (j = 0; j < n_choices; j += 1)
4021 choices[j] = j;
4022 break;
4023 }
14f9c5c9
AS
4024 choice -= first_choice;
4025
d2e4a39e 4026 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4027 {
4028 }
14f9c5c9
AS
4029
4030 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4031 {
4032 int k;
5b4ee69b 4033
4c4b4cd2
PH
4034 for (k = n_chosen - 1; k > j; k -= 1)
4035 choices[k + 1] = choices[k];
4036 choices[j + 1] = choice;
4037 n_chosen += 1;
4038 }
14f9c5c9
AS
4039 }
4040
4041 if (n_chosen > max_results)
323e0a4a 4042 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4043
14f9c5c9
AS
4044 return n_chosen;
4045}
4046
4c4b4cd2
PH
4047/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4048 on the function identified by SYM and BLOCK, and taking NARGS
4049 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4050
4051static void
e9d9f57e 4052replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4053 int oplen, struct symbol *sym,
270140bd 4054 const struct block *block)
14f9c5c9
AS
4055{
4056 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4057 symbol, -oplen for operator being replaced). */
d2e4a39e 4058 struct expression *newexp = (struct expression *)
8c1a34e7 4059 xzalloc (sizeof (struct expression)
4c4b4cd2 4060 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4061 struct expression *exp = expp->get ();
14f9c5c9
AS
4062
4063 newexp->nelts = exp->nelts + 7 - oplen;
4064 newexp->language_defn = exp->language_defn;
3489610d 4065 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4066 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4067 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4068 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4069
4070 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4071 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4072
4073 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4074 newexp->elts[pc + 4].block = block;
4075 newexp->elts[pc + 5].symbol = sym;
4076
e9d9f57e 4077 expp->reset (newexp);
d2e4a39e 4078}
14f9c5c9
AS
4079
4080/* Type-class predicates */
4081
4c4b4cd2
PH
4082/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4083 or FLOAT). */
14f9c5c9
AS
4084
4085static int
d2e4a39e 4086numeric_type_p (struct type *type)
14f9c5c9
AS
4087{
4088 if (type == NULL)
4089 return 0;
d2e4a39e
AS
4090 else
4091 {
4092 switch (TYPE_CODE (type))
4c4b4cd2
PH
4093 {
4094 case TYPE_CODE_INT:
4095 case TYPE_CODE_FLT:
4096 return 1;
4097 case TYPE_CODE_RANGE:
4098 return (type == TYPE_TARGET_TYPE (type)
4099 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4100 default:
4101 return 0;
4102 }
d2e4a39e 4103 }
14f9c5c9
AS
4104}
4105
4c4b4cd2 4106/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4107
4108static int
d2e4a39e 4109integer_type_p (struct type *type)
14f9c5c9
AS
4110{
4111 if (type == NULL)
4112 return 0;
d2e4a39e
AS
4113 else
4114 {
4115 switch (TYPE_CODE (type))
4c4b4cd2
PH
4116 {
4117 case TYPE_CODE_INT:
4118 return 1;
4119 case TYPE_CODE_RANGE:
4120 return (type == TYPE_TARGET_TYPE (type)
4121 || integer_type_p (TYPE_TARGET_TYPE (type)));
4122 default:
4123 return 0;
4124 }
d2e4a39e 4125 }
14f9c5c9
AS
4126}
4127
4c4b4cd2 4128/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4129
4130static int
d2e4a39e 4131scalar_type_p (struct type *type)
14f9c5c9
AS
4132{
4133 if (type == NULL)
4134 return 0;
d2e4a39e
AS
4135 else
4136 {
4137 switch (TYPE_CODE (type))
4c4b4cd2
PH
4138 {
4139 case TYPE_CODE_INT:
4140 case TYPE_CODE_RANGE:
4141 case TYPE_CODE_ENUM:
4142 case TYPE_CODE_FLT:
4143 return 1;
4144 default:
4145 return 0;
4146 }
d2e4a39e 4147 }
14f9c5c9
AS
4148}
4149
4c4b4cd2 4150/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4151
4152static int
d2e4a39e 4153discrete_type_p (struct type *type)
14f9c5c9
AS
4154{
4155 if (type == NULL)
4156 return 0;
d2e4a39e
AS
4157 else
4158 {
4159 switch (TYPE_CODE (type))
4c4b4cd2
PH
4160 {
4161 case TYPE_CODE_INT:
4162 case TYPE_CODE_RANGE:
4163 case TYPE_CODE_ENUM:
872f0337 4164 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4165 return 1;
4166 default:
4167 return 0;
4168 }
d2e4a39e 4169 }
14f9c5c9
AS
4170}
4171
4c4b4cd2
PH
4172/* Returns non-zero if OP with operands in the vector ARGS could be
4173 a user-defined function. Errs on the side of pre-defined operators
4174 (i.e., result 0). */
14f9c5c9
AS
4175
4176static int
d2e4a39e 4177possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4178{
76a01679 4179 struct type *type0 =
df407dfe 4180 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4181 struct type *type1 =
df407dfe 4182 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4183
4c4b4cd2
PH
4184 if (type0 == NULL)
4185 return 0;
4186
14f9c5c9
AS
4187 switch (op)
4188 {
4189 default:
4190 return 0;
4191
4192 case BINOP_ADD:
4193 case BINOP_SUB:
4194 case BINOP_MUL:
4195 case BINOP_DIV:
d2e4a39e 4196 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4197
4198 case BINOP_REM:
4199 case BINOP_MOD:
4200 case BINOP_BITWISE_AND:
4201 case BINOP_BITWISE_IOR:
4202 case BINOP_BITWISE_XOR:
d2e4a39e 4203 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4204
4205 case BINOP_EQUAL:
4206 case BINOP_NOTEQUAL:
4207 case BINOP_LESS:
4208 case BINOP_GTR:
4209 case BINOP_LEQ:
4210 case BINOP_GEQ:
d2e4a39e 4211 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4212
4213 case BINOP_CONCAT:
ee90b9ab 4214 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4215
4216 case BINOP_EXP:
d2e4a39e 4217 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4218
4219 case UNOP_NEG:
4220 case UNOP_PLUS:
4221 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4222 case UNOP_ABS:
4223 return (!numeric_type_p (type0));
14f9c5c9
AS
4224
4225 }
4226}
4227\f
4c4b4cd2 4228 /* Renaming */
14f9c5c9 4229
aeb5907d
JB
4230/* NOTES:
4231
4232 1. In the following, we assume that a renaming type's name may
4233 have an ___XD suffix. It would be nice if this went away at some
4234 point.
4235 2. We handle both the (old) purely type-based representation of
4236 renamings and the (new) variable-based encoding. At some point,
4237 it is devoutly to be hoped that the former goes away
4238 (FIXME: hilfinger-2007-07-09).
4239 3. Subprogram renamings are not implemented, although the XRS
4240 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4241
4242/* If SYM encodes a renaming,
4243
4244 <renaming> renames <renamed entity>,
4245
4246 sets *LEN to the length of the renamed entity's name,
4247 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4248 the string describing the subcomponent selected from the renamed
0963b4bd 4249 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4250 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4251 are undefined). Otherwise, returns a value indicating the category
4252 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4253 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4254 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4255 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4256 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4257 may be NULL, in which case they are not assigned.
4258
4259 [Currently, however, GCC does not generate subprogram renamings.] */
4260
4261enum ada_renaming_category
4262ada_parse_renaming (struct symbol *sym,
4263 const char **renamed_entity, int *len,
4264 const char **renaming_expr)
4265{
4266 enum ada_renaming_category kind;
4267 const char *info;
4268 const char *suffix;
4269
4270 if (sym == NULL)
4271 return ADA_NOT_RENAMING;
4272 switch (SYMBOL_CLASS (sym))
14f9c5c9 4273 {
aeb5907d
JB
4274 default:
4275 return ADA_NOT_RENAMING;
aeb5907d
JB
4276 case LOC_LOCAL:
4277 case LOC_STATIC:
4278 case LOC_COMPUTED:
4279 case LOC_OPTIMIZED_OUT:
4280 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4281 if (info == NULL)
4282 return ADA_NOT_RENAMING;
4283 switch (info[5])
4284 {
4285 case '_':
4286 kind = ADA_OBJECT_RENAMING;
4287 info += 6;
4288 break;
4289 case 'E':
4290 kind = ADA_EXCEPTION_RENAMING;
4291 info += 7;
4292 break;
4293 case 'P':
4294 kind = ADA_PACKAGE_RENAMING;
4295 info += 7;
4296 break;
4297 case 'S':
4298 kind = ADA_SUBPROGRAM_RENAMING;
4299 info += 7;
4300 break;
4301 default:
4302 return ADA_NOT_RENAMING;
4303 }
14f9c5c9 4304 }
4c4b4cd2 4305
aeb5907d
JB
4306 if (renamed_entity != NULL)
4307 *renamed_entity = info;
4308 suffix = strstr (info, "___XE");
4309 if (suffix == NULL || suffix == info)
4310 return ADA_NOT_RENAMING;
4311 if (len != NULL)
4312 *len = strlen (info) - strlen (suffix);
4313 suffix += 5;
4314 if (renaming_expr != NULL)
4315 *renaming_expr = suffix;
4316 return kind;
4317}
4318
a5ee536b
JB
4319/* Compute the value of the given RENAMING_SYM, which is expected to
4320 be a symbol encoding a renaming expression. BLOCK is the block
4321 used to evaluate the renaming. */
52ce6436 4322
a5ee536b
JB
4323static struct value *
4324ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4325 const struct block *block)
a5ee536b 4326{
bbc13ae3 4327 const char *sym_name;
a5ee536b 4328
bbc13ae3 4329 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4330 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4331 return evaluate_expression (expr.get ());
a5ee536b 4332}
14f9c5c9 4333\f
d2e4a39e 4334
4c4b4cd2 4335 /* Evaluation: Function Calls */
14f9c5c9 4336
4c4b4cd2 4337/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4338 lvalues, and otherwise has the side-effect of allocating memory
4339 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4340
d2e4a39e 4341static struct value *
40bc484c 4342ensure_lval (struct value *val)
14f9c5c9 4343{
40bc484c
JB
4344 if (VALUE_LVAL (val) == not_lval
4345 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4346 {
df407dfe 4347 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4348 const CORE_ADDR addr =
4349 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4350
a84a8a0d 4351 VALUE_LVAL (val) = lval_memory;
1a088441 4352 set_value_address (val, addr);
40bc484c 4353 write_memory (addr, value_contents (val), len);
c3e5cd34 4354 }
14f9c5c9
AS
4355
4356 return val;
4357}
4358
4359/* Return the value ACTUAL, converted to be an appropriate value for a
4360 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4361 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4362 values not residing in memory, updating it as needed. */
14f9c5c9 4363
a93c0eb6 4364struct value *
40bc484c 4365ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4366{
df407dfe 4367 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4368 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4369 struct type *formal_target =
4370 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4371 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4372 struct type *actual_target =
4373 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4374 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4375
4c4b4cd2 4376 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4377 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4378 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4379 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4380 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4381 {
a84a8a0d 4382 struct value *result;
5b4ee69b 4383
14f9c5c9 4384 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4385 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4386 result = desc_data (actual);
cb923fcc 4387 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4388 {
4389 if (VALUE_LVAL (actual) != lval_memory)
4390 {
4391 struct value *val;
5b4ee69b 4392
df407dfe 4393 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4394 val = allocate_value (actual_type);
990a07ab 4395 memcpy ((char *) value_contents_raw (val),
0fd88904 4396 (char *) value_contents (actual),
4c4b4cd2 4397 TYPE_LENGTH (actual_type));
40bc484c 4398 actual = ensure_lval (val);
4c4b4cd2 4399 }
a84a8a0d 4400 result = value_addr (actual);
4c4b4cd2 4401 }
a84a8a0d
JB
4402 else
4403 return actual;
b1af9e97 4404 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4405 }
4406 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4407 return ada_value_ind (actual);
8344af1e
JB
4408 else if (ada_is_aligner_type (formal_type))
4409 {
4410 /* We need to turn this parameter into an aligner type
4411 as well. */
4412 struct value *aligner = allocate_value (formal_type);
4413 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4414
4415 value_assign_to_component (aligner, component, actual);
4416 return aligner;
4417 }
14f9c5c9
AS
4418
4419 return actual;
4420}
4421
438c98a1
JB
4422/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4423 type TYPE. This is usually an inefficient no-op except on some targets
4424 (such as AVR) where the representation of a pointer and an address
4425 differs. */
4426
4427static CORE_ADDR
4428value_pointer (struct value *value, struct type *type)
4429{
4430 struct gdbarch *gdbarch = get_type_arch (type);
4431 unsigned len = TYPE_LENGTH (type);
224c3ddb 4432 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4433 CORE_ADDR addr;
4434
4435 addr = value_address (value);
4436 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4437 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4438 return addr;
4439}
4440
14f9c5c9 4441
4c4b4cd2
PH
4442/* Push a descriptor of type TYPE for array value ARR on the stack at
4443 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4444 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4445 to-descriptor type rather than a descriptor type), a struct value *
4446 representing a pointer to this descriptor. */
14f9c5c9 4447
d2e4a39e 4448static struct value *
40bc484c 4449make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4450{
d2e4a39e
AS
4451 struct type *bounds_type = desc_bounds_type (type);
4452 struct type *desc_type = desc_base_type (type);
4453 struct value *descriptor = allocate_value (desc_type);
4454 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4455 int i;
d2e4a39e 4456
0963b4bd
MS
4457 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4458 i > 0; i -= 1)
14f9c5c9 4459 {
19f220c3
JK
4460 modify_field (value_type (bounds), value_contents_writeable (bounds),
4461 ada_array_bound (arr, i, 0),
4462 desc_bound_bitpos (bounds_type, i, 0),
4463 desc_bound_bitsize (bounds_type, i, 0));
4464 modify_field (value_type (bounds), value_contents_writeable (bounds),
4465 ada_array_bound (arr, i, 1),
4466 desc_bound_bitpos (bounds_type, i, 1),
4467 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4468 }
d2e4a39e 4469
40bc484c 4470 bounds = ensure_lval (bounds);
d2e4a39e 4471
19f220c3
JK
4472 modify_field (value_type (descriptor),
4473 value_contents_writeable (descriptor),
4474 value_pointer (ensure_lval (arr),
4475 TYPE_FIELD_TYPE (desc_type, 0)),
4476 fat_pntr_data_bitpos (desc_type),
4477 fat_pntr_data_bitsize (desc_type));
4478
4479 modify_field (value_type (descriptor),
4480 value_contents_writeable (descriptor),
4481 value_pointer (bounds,
4482 TYPE_FIELD_TYPE (desc_type, 1)),
4483 fat_pntr_bounds_bitpos (desc_type),
4484 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4485
40bc484c 4486 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4487
4488 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4489 return value_addr (descriptor);
4490 else
4491 return descriptor;
4492}
14f9c5c9 4493\f
3d9434b5
JB
4494 /* Symbol Cache Module */
4495
3d9434b5 4496/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4497 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4498 on the type of entity being printed, the cache can make it as much
4499 as an order of magnitude faster than without it.
4500
4501 The descriptive type DWARF extension has significantly reduced
4502 the need for this cache, at least when DWARF is being used. However,
4503 even in this case, some expensive name-based symbol searches are still
4504 sometimes necessary - to find an XVZ variable, mostly. */
4505
ee01b665 4506/* Initialize the contents of SYM_CACHE. */
3d9434b5 4507
ee01b665
JB
4508static void
4509ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4510{
4511 obstack_init (&sym_cache->cache_space);
4512 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4513}
3d9434b5 4514
ee01b665
JB
4515/* Free the memory used by SYM_CACHE. */
4516
4517static void
4518ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4519{
ee01b665
JB
4520 obstack_free (&sym_cache->cache_space, NULL);
4521 xfree (sym_cache);
4522}
3d9434b5 4523
ee01b665
JB
4524/* Return the symbol cache associated to the given program space PSPACE.
4525 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4526
ee01b665
JB
4527static struct ada_symbol_cache *
4528ada_get_symbol_cache (struct program_space *pspace)
4529{
4530 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4531
66c168ae 4532 if (pspace_data->sym_cache == NULL)
ee01b665 4533 {
66c168ae
JB
4534 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4535 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4536 }
4537
66c168ae 4538 return pspace_data->sym_cache;
ee01b665 4539}
3d9434b5
JB
4540
4541/* Clear all entries from the symbol cache. */
4542
4543static void
4544ada_clear_symbol_cache (void)
4545{
ee01b665
JB
4546 struct ada_symbol_cache *sym_cache
4547 = ada_get_symbol_cache (current_program_space);
4548
4549 obstack_free (&sym_cache->cache_space, NULL);
4550 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4551}
4552
fe978cb0 4553/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4554 Return it if found, or NULL otherwise. */
4555
4556static struct cache_entry **
fe978cb0 4557find_entry (const char *name, domain_enum domain)
3d9434b5 4558{
ee01b665
JB
4559 struct ada_symbol_cache *sym_cache
4560 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4561 int h = msymbol_hash (name) % HASH_SIZE;
4562 struct cache_entry **e;
4563
ee01b665 4564 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4565 {
fe978cb0 4566 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4567 return e;
4568 }
4569 return NULL;
4570}
4571
fe978cb0 4572/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4573 Return 1 if found, 0 otherwise.
4574
4575 If an entry was found and SYM is not NULL, set *SYM to the entry's
4576 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4577
96d887e8 4578static int
fe978cb0 4579lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4580 struct symbol **sym, const struct block **block)
96d887e8 4581{
fe978cb0 4582 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4583
4584 if (e == NULL)
4585 return 0;
4586 if (sym != NULL)
4587 *sym = (*e)->sym;
4588 if (block != NULL)
4589 *block = (*e)->block;
4590 return 1;
96d887e8
PH
4591}
4592
3d9434b5 4593/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4594 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4595
96d887e8 4596static void
fe978cb0 4597cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4598 const struct block *block)
96d887e8 4599{
ee01b665
JB
4600 struct ada_symbol_cache *sym_cache
4601 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4602 int h;
4603 char *copy;
4604 struct cache_entry *e;
4605
1994afbf
DE
4606 /* Symbols for builtin types don't have a block.
4607 For now don't cache such symbols. */
4608 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4609 return;
4610
3d9434b5
JB
4611 /* If the symbol is a local symbol, then do not cache it, as a search
4612 for that symbol depends on the context. To determine whether
4613 the symbol is local or not, we check the block where we found it
4614 against the global and static blocks of its associated symtab. */
4615 if (sym
08be3fe3 4616 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4617 GLOBAL_BLOCK) != block
08be3fe3 4618 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4619 STATIC_BLOCK) != block)
3d9434b5
JB
4620 return;
4621
4622 h = msymbol_hash (name) % HASH_SIZE;
e39db4db 4623 e = XOBNEW (&sym_cache->cache_space, cache_entry);
ee01b665
JB
4624 e->next = sym_cache->root[h];
4625 sym_cache->root[h] = e;
224c3ddb
SM
4626 e->name = copy
4627 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4628 strcpy (copy, name);
4629 e->sym = sym;
fe978cb0 4630 e->domain = domain;
3d9434b5 4631 e->block = block;
96d887e8 4632}
4c4b4cd2
PH
4633\f
4634 /* Symbol Lookup */
4635
b5ec771e
PA
4636/* Return the symbol name match type that should be used used when
4637 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4638
4639 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4640 for Ada lookups. */
c0431670 4641
b5ec771e
PA
4642static symbol_name_match_type
4643name_match_type_from_name (const char *lookup_name)
c0431670 4644{
b5ec771e
PA
4645 return (strstr (lookup_name, "__") == NULL
4646 ? symbol_name_match_type::WILD
4647 : symbol_name_match_type::FULL);
c0431670
JB
4648}
4649
4c4b4cd2
PH
4650/* Return the result of a standard (literal, C-like) lookup of NAME in
4651 given DOMAIN, visible from lexical block BLOCK. */
4652
4653static struct symbol *
4654standard_lookup (const char *name, const struct block *block,
4655 domain_enum domain)
4656{
acbd605d 4657 /* Initialize it just to avoid a GCC false warning. */
6640a367 4658 struct block_symbol sym = {};
4c4b4cd2 4659
d12307c1
PMR
4660 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4661 return sym.symbol;
a2cd4f14 4662 ada_lookup_encoded_symbol (name, block, domain, &sym);
d12307c1
PMR
4663 cache_symbol (name, domain, sym.symbol, sym.block);
4664 return sym.symbol;
4c4b4cd2
PH
4665}
4666
4667
4668/* Non-zero iff there is at least one non-function/non-enumeral symbol
4669 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4670 since they contend in overloading in the same way. */
4671static int
d12307c1 4672is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4673{
4674 int i;
4675
4676 for (i = 0; i < n; i += 1)
d12307c1
PMR
4677 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4678 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4679 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4680 return 1;
4681
4682 return 0;
4683}
4684
4685/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4686 struct types. Otherwise, they may not. */
14f9c5c9
AS
4687
4688static int
d2e4a39e 4689equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4690{
d2e4a39e 4691 if (type0 == type1)
14f9c5c9 4692 return 1;
d2e4a39e 4693 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4694 || TYPE_CODE (type0) != TYPE_CODE (type1))
4695 return 0;
d2e4a39e 4696 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4697 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4698 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4699 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4700 return 1;
d2e4a39e 4701
14f9c5c9
AS
4702 return 0;
4703}
4704
4705/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4706 no more defined than that of SYM1. */
14f9c5c9
AS
4707
4708static int
d2e4a39e 4709lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4710{
4711 if (sym0 == sym1)
4712 return 1;
176620f1 4713 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4714 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4715 return 0;
4716
d2e4a39e 4717 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4718 {
4719 case LOC_UNDEF:
4720 return 1;
4721 case LOC_TYPEDEF:
4722 {
4c4b4cd2
PH
4723 struct type *type0 = SYMBOL_TYPE (sym0);
4724 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4725 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4726 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4727 int len0 = strlen (name0);
5b4ee69b 4728
4c4b4cd2
PH
4729 return
4730 TYPE_CODE (type0) == TYPE_CODE (type1)
4731 && (equiv_types (type0, type1)
4732 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4733 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4734 }
4735 case LOC_CONST:
4736 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4737 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4738 default:
4739 return 0;
14f9c5c9
AS
4740 }
4741}
4742
d12307c1 4743/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4744 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4745
4746static void
76a01679
JB
4747add_defn_to_vec (struct obstack *obstackp,
4748 struct symbol *sym,
f0c5f9b2 4749 const struct block *block)
14f9c5c9
AS
4750{
4751 int i;
d12307c1 4752 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4753
529cad9c
PH
4754 /* Do not try to complete stub types, as the debugger is probably
4755 already scanning all symbols matching a certain name at the
4756 time when this function is called. Trying to replace the stub
4757 type by its associated full type will cause us to restart a scan
4758 which may lead to an infinite recursion. Instead, the client
4759 collecting the matching symbols will end up collecting several
4760 matches, with at least one of them complete. It can then filter
4761 out the stub ones if needed. */
4762
4c4b4cd2
PH
4763 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4764 {
d12307c1 4765 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4766 return;
d12307c1 4767 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4768 {
d12307c1 4769 prevDefns[i].symbol = sym;
4c4b4cd2 4770 prevDefns[i].block = block;
4c4b4cd2 4771 return;
76a01679 4772 }
4c4b4cd2
PH
4773 }
4774
4775 {
d12307c1 4776 struct block_symbol info;
4c4b4cd2 4777
d12307c1 4778 info.symbol = sym;
4c4b4cd2 4779 info.block = block;
d12307c1 4780 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4781 }
4782}
4783
d12307c1
PMR
4784/* Number of block_symbol structures currently collected in current vector in
4785 OBSTACKP. */
4c4b4cd2 4786
76a01679
JB
4787static int
4788num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4789{
d12307c1 4790 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4791}
4792
d12307c1
PMR
4793/* Vector of block_symbol structures currently collected in current vector in
4794 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4795
d12307c1 4796static struct block_symbol *
4c4b4cd2
PH
4797defns_collected (struct obstack *obstackp, int finish)
4798{
4799 if (finish)
224c3ddb 4800 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4801 else
d12307c1 4802 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4803}
4804
7c7b6655
TT
4805/* Return a bound minimal symbol matching NAME according to Ada
4806 decoding rules. Returns an invalid symbol if there is no such
4807 minimal symbol. Names prefixed with "standard__" are handled
4808 specially: "standard__" is first stripped off, and only static and
4809 global symbols are searched. */
4c4b4cd2 4810
7c7b6655 4811struct bound_minimal_symbol
96d887e8 4812ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4813{
7c7b6655 4814 struct bound_minimal_symbol result;
4c4b4cd2 4815
7c7b6655
TT
4816 memset (&result, 0, sizeof (result));
4817
b5ec771e
PA
4818 symbol_name_match_type match_type = name_match_type_from_name (name);
4819 lookup_name_info lookup_name (name, match_type);
4820
4821 symbol_name_matcher_ftype *match_name
4822 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4823
2030c079 4824 for (objfile *objfile : current_program_space->objfiles ())
5325b9bf 4825 {
7932255d 4826 for (minimal_symbol *msymbol : objfile->msymbols ())
5325b9bf
TT
4827 {
4828 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4829 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4830 {
4831 result.minsym = msymbol;
4832 result.objfile = objfile;
4833 break;
4834 }
4835 }
4836 }
4c4b4cd2 4837
7c7b6655 4838 return result;
96d887e8 4839}
4c4b4cd2 4840
2ff0a947
TT
4841/* Return all the bound minimal symbols matching NAME according to Ada
4842 decoding rules. Returns an empty vector if there is no such
4843 minimal symbol. Names prefixed with "standard__" are handled
4844 specially: "standard__" is first stripped off, and only static and
4845 global symbols are searched. */
4846
4847static std::vector<struct bound_minimal_symbol>
4848ada_lookup_simple_minsyms (const char *name)
4849{
4850 std::vector<struct bound_minimal_symbol> result;
4851
4852 symbol_name_match_type match_type = name_match_type_from_name (name);
4853 lookup_name_info lookup_name (name, match_type);
4854
4855 symbol_name_matcher_ftype *match_name
4856 = ada_get_symbol_name_matcher (lookup_name);
4857
4858 for (objfile *objfile : current_program_space->objfiles ())
4859 {
4860 for (minimal_symbol *msymbol : objfile->msymbols ())
4861 {
4862 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4863 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4864 result.push_back ({msymbol, objfile});
4865 }
4866 }
4867
4868 return result;
4869}
4870
96d887e8
PH
4871/* For all subprograms that statically enclose the subprogram of the
4872 selected frame, add symbols matching identifier NAME in DOMAIN
4873 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4874 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4875 with a wildcard prefix. */
4c4b4cd2 4876
96d887e8
PH
4877static void
4878add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4879 const lookup_name_info &lookup_name,
4880 domain_enum domain)
96d887e8 4881{
96d887e8 4882}
14f9c5c9 4883
96d887e8
PH
4884/* True if TYPE is definitely an artificial type supplied to a symbol
4885 for which no debugging information was given in the symbol file. */
14f9c5c9 4886
96d887e8
PH
4887static int
4888is_nondebugging_type (struct type *type)
4889{
0d5cff50 4890 const char *name = ada_type_name (type);
5b4ee69b 4891
96d887e8
PH
4892 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4893}
4c4b4cd2 4894
8f17729f
JB
4895/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4896 that are deemed "identical" for practical purposes.
4897
4898 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4899 types and that their number of enumerals is identical (in other
4900 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4901
4902static int
4903ada_identical_enum_types_p (struct type *type1, struct type *type2)
4904{
4905 int i;
4906
4907 /* The heuristic we use here is fairly conservative. We consider
4908 that 2 enumerate types are identical if they have the same
4909 number of enumerals and that all enumerals have the same
4910 underlying value and name. */
4911
4912 /* All enums in the type should have an identical underlying value. */
4913 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4914 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4915 return 0;
4916
4917 /* All enumerals should also have the same name (modulo any numerical
4918 suffix). */
4919 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4920 {
0d5cff50
DE
4921 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4922 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4923 int len_1 = strlen (name_1);
4924 int len_2 = strlen (name_2);
4925
4926 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4927 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4928 if (len_1 != len_2
4929 || strncmp (TYPE_FIELD_NAME (type1, i),
4930 TYPE_FIELD_NAME (type2, i),
4931 len_1) != 0)
4932 return 0;
4933 }
4934
4935 return 1;
4936}
4937
4938/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4939 that are deemed "identical" for practical purposes. Sometimes,
4940 enumerals are not strictly identical, but their types are so similar
4941 that they can be considered identical.
4942
4943 For instance, consider the following code:
4944
4945 type Color is (Black, Red, Green, Blue, White);
4946 type RGB_Color is new Color range Red .. Blue;
4947
4948 Type RGB_Color is a subrange of an implicit type which is a copy
4949 of type Color. If we call that implicit type RGB_ColorB ("B" is
4950 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4951 As a result, when an expression references any of the enumeral
4952 by name (Eg. "print green"), the expression is technically
4953 ambiguous and the user should be asked to disambiguate. But
4954 doing so would only hinder the user, since it wouldn't matter
4955 what choice he makes, the outcome would always be the same.
4956 So, for practical purposes, we consider them as the same. */
4957
4958static int
54d343a2 4959symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
4960{
4961 int i;
4962
4963 /* Before performing a thorough comparison check of each type,
4964 we perform a series of inexpensive checks. We expect that these
4965 checks will quickly fail in the vast majority of cases, and thus
4966 help prevent the unnecessary use of a more expensive comparison.
4967 Said comparison also expects us to make some of these checks
4968 (see ada_identical_enum_types_p). */
4969
4970 /* Quick check: All symbols should have an enum type. */
54d343a2 4971 for (i = 0; i < syms.size (); i++)
d12307c1 4972 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
4973 return 0;
4974
4975 /* Quick check: They should all have the same value. */
54d343a2 4976 for (i = 1; i < syms.size (); i++)
d12307c1 4977 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
4978 return 0;
4979
4980 /* Quick check: They should all have the same number of enumerals. */
54d343a2 4981 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
4982 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
4983 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
4984 return 0;
4985
4986 /* All the sanity checks passed, so we might have a set of
4987 identical enumeration types. Perform a more complete
4988 comparison of the type of each symbol. */
54d343a2 4989 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
4990 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4991 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
4992 return 0;
4993
4994 return 1;
4995}
4996
54d343a2 4997/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
4998 duplicate other symbols in the list (The only case I know of where
4999 this happens is when object files containing stabs-in-ecoff are
5000 linked with files containing ordinary ecoff debugging symbols (or no
5001 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5002 Returns the number of items in the modified list. */
4c4b4cd2 5003
96d887e8 5004static int
54d343a2 5005remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5006{
5007 int i, j;
4c4b4cd2 5008
8f17729f
JB
5009 /* We should never be called with less than 2 symbols, as there
5010 cannot be any extra symbol in that case. But it's easy to
5011 handle, since we have nothing to do in that case. */
54d343a2
TT
5012 if (syms->size () < 2)
5013 return syms->size ();
8f17729f 5014
96d887e8 5015 i = 0;
54d343a2 5016 while (i < syms->size ())
96d887e8 5017 {
a35ddb44 5018 int remove_p = 0;
339c13b6
JB
5019
5020 /* If two symbols have the same name and one of them is a stub type,
5021 the get rid of the stub. */
5022
54d343a2
TT
5023 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5024 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5025 {
54d343a2 5026 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5027 {
5028 if (j != i
54d343a2
TT
5029 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5030 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5031 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5032 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5033 remove_p = 1;
339c13b6
JB
5034 }
5035 }
5036
5037 /* Two symbols with the same name, same class and same address
5038 should be identical. */
5039
54d343a2
TT
5040 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5041 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5042 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5043 {
54d343a2 5044 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5045 {
5046 if (i != j
54d343a2
TT
5047 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5048 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5049 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5050 && SYMBOL_CLASS ((*syms)[i].symbol)
5051 == SYMBOL_CLASS ((*syms)[j].symbol)
5052 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5053 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5054 remove_p = 1;
4c4b4cd2 5055 }
4c4b4cd2 5056 }
339c13b6 5057
a35ddb44 5058 if (remove_p)
54d343a2 5059 syms->erase (syms->begin () + i);
339c13b6 5060
96d887e8 5061 i += 1;
14f9c5c9 5062 }
8f17729f
JB
5063
5064 /* If all the remaining symbols are identical enumerals, then
5065 just keep the first one and discard the rest.
5066
5067 Unlike what we did previously, we do not discard any entry
5068 unless they are ALL identical. This is because the symbol
5069 comparison is not a strict comparison, but rather a practical
5070 comparison. If all symbols are considered identical, then
5071 we can just go ahead and use the first one and discard the rest.
5072 But if we cannot reduce the list to a single element, we have
5073 to ask the user to disambiguate anyways. And if we have to
5074 present a multiple-choice menu, it's less confusing if the list
5075 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5076 if (symbols_are_identical_enums (*syms))
5077 syms->resize (1);
8f17729f 5078
54d343a2 5079 return syms->size ();
14f9c5c9
AS
5080}
5081
96d887e8
PH
5082/* Given a type that corresponds to a renaming entity, use the type name
5083 to extract the scope (package name or function name, fully qualified,
5084 and following the GNAT encoding convention) where this renaming has been
49d83361 5085 defined. */
4c4b4cd2 5086
49d83361 5087static std::string
96d887e8 5088xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5089{
96d887e8 5090 /* The renaming types adhere to the following convention:
0963b4bd 5091 <scope>__<rename>___<XR extension>.
96d887e8
PH
5092 So, to extract the scope, we search for the "___XR" extension,
5093 and then backtrack until we find the first "__". */
76a01679 5094
a737d952 5095 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5096 const char *suffix = strstr (name, "___XR");
5097 const char *last;
14f9c5c9 5098
96d887e8
PH
5099 /* Now, backtrack a bit until we find the first "__". Start looking
5100 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5101
96d887e8
PH
5102 for (last = suffix - 3; last > name; last--)
5103 if (last[0] == '_' && last[1] == '_')
5104 break;
76a01679 5105
96d887e8 5106 /* Make a copy of scope and return it. */
49d83361 5107 return std::string (name, last);
4c4b4cd2
PH
5108}
5109
96d887e8 5110/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5111
96d887e8
PH
5112static int
5113is_package_name (const char *name)
4c4b4cd2 5114{
96d887e8
PH
5115 /* Here, We take advantage of the fact that no symbols are generated
5116 for packages, while symbols are generated for each function.
5117 So the condition for NAME represent a package becomes equivalent
5118 to NAME not existing in our list of symbols. There is only one
5119 small complication with library-level functions (see below). */
4c4b4cd2 5120
96d887e8
PH
5121 /* If it is a function that has not been defined at library level,
5122 then we should be able to look it up in the symbols. */
5123 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5124 return 0;
14f9c5c9 5125
96d887e8
PH
5126 /* Library-level function names start with "_ada_". See if function
5127 "_ada_" followed by NAME can be found. */
14f9c5c9 5128
96d887e8 5129 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5130 functions names cannot contain "__" in them. */
96d887e8
PH
5131 if (strstr (name, "__") != NULL)
5132 return 0;
4c4b4cd2 5133
528e1572 5134 std::string fun_name = string_printf ("_ada_%s", name);
14f9c5c9 5135
528e1572 5136 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
96d887e8 5137}
14f9c5c9 5138
96d887e8 5139/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5140 not visible from FUNCTION_NAME. */
14f9c5c9 5141
96d887e8 5142static int
0d5cff50 5143old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5144{
aeb5907d
JB
5145 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5146 return 0;
5147
49d83361 5148 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5149
96d887e8 5150 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5151 if (is_package_name (scope.c_str ()))
5152 return 0;
14f9c5c9 5153
96d887e8
PH
5154 /* Check that the rename is in the current function scope by checking
5155 that its name starts with SCOPE. */
76a01679 5156
96d887e8
PH
5157 /* If the function name starts with "_ada_", it means that it is
5158 a library-level function. Strip this prefix before doing the
5159 comparison, as the encoding for the renaming does not contain
5160 this prefix. */
61012eef 5161 if (startswith (function_name, "_ada_"))
96d887e8 5162 function_name += 5;
f26caa11 5163
49d83361 5164 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5165}
5166
aeb5907d
JB
5167/* Remove entries from SYMS that corresponds to a renaming entity that
5168 is not visible from the function associated with CURRENT_BLOCK or
5169 that is superfluous due to the presence of more specific renaming
5170 information. Places surviving symbols in the initial entries of
5171 SYMS and returns the number of surviving symbols.
96d887e8
PH
5172
5173 Rationale:
aeb5907d
JB
5174 First, in cases where an object renaming is implemented as a
5175 reference variable, GNAT may produce both the actual reference
5176 variable and the renaming encoding. In this case, we discard the
5177 latter.
5178
5179 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5180 entity. Unfortunately, STABS currently does not support the definition
5181 of types that are local to a given lexical block, so all renamings types
5182 are emitted at library level. As a consequence, if an application
5183 contains two renaming entities using the same name, and a user tries to
5184 print the value of one of these entities, the result of the ada symbol
5185 lookup will also contain the wrong renaming type.
f26caa11 5186
96d887e8
PH
5187 This function partially covers for this limitation by attempting to
5188 remove from the SYMS list renaming symbols that should be visible
5189 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5190 method with the current information available. The implementation
5191 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5192
5193 - When the user tries to print a rename in a function while there
5194 is another rename entity defined in a package: Normally, the
5195 rename in the function has precedence over the rename in the
5196 package, so the latter should be removed from the list. This is
5197 currently not the case.
5198
5199 - This function will incorrectly remove valid renames if
5200 the CURRENT_BLOCK corresponds to a function which symbol name
5201 has been changed by an "Export" pragma. As a consequence,
5202 the user will be unable to print such rename entities. */
4c4b4cd2 5203
14f9c5c9 5204static int
54d343a2
TT
5205remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5206 const struct block *current_block)
4c4b4cd2
PH
5207{
5208 struct symbol *current_function;
0d5cff50 5209 const char *current_function_name;
4c4b4cd2 5210 int i;
aeb5907d
JB
5211 int is_new_style_renaming;
5212
5213 /* If there is both a renaming foo___XR... encoded as a variable and
5214 a simple variable foo in the same block, discard the latter.
0963b4bd 5215 First, zero out such symbols, then compress. */
aeb5907d 5216 is_new_style_renaming = 0;
54d343a2 5217 for (i = 0; i < syms->size (); i += 1)
aeb5907d 5218 {
54d343a2
TT
5219 struct symbol *sym = (*syms)[i].symbol;
5220 const struct block *block = (*syms)[i].block;
aeb5907d
JB
5221 const char *name;
5222 const char *suffix;
5223
5224 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5225 continue;
5226 name = SYMBOL_LINKAGE_NAME (sym);
5227 suffix = strstr (name, "___XR");
5228
5229 if (suffix != NULL)
5230 {
5231 int name_len = suffix - name;
5232 int j;
5b4ee69b 5233
aeb5907d 5234 is_new_style_renaming = 1;
54d343a2
TT
5235 for (j = 0; j < syms->size (); j += 1)
5236 if (i != j && (*syms)[j].symbol != NULL
5237 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
aeb5907d 5238 name_len) == 0
54d343a2
TT
5239 && block == (*syms)[j].block)
5240 (*syms)[j].symbol = NULL;
aeb5907d
JB
5241 }
5242 }
5243 if (is_new_style_renaming)
5244 {
5245 int j, k;
5246
54d343a2
TT
5247 for (j = k = 0; j < syms->size (); j += 1)
5248 if ((*syms)[j].symbol != NULL)
aeb5907d 5249 {
54d343a2 5250 (*syms)[k] = (*syms)[j];
aeb5907d
JB
5251 k += 1;
5252 }
5253 return k;
5254 }
4c4b4cd2
PH
5255
5256 /* Extract the function name associated to CURRENT_BLOCK.
5257 Abort if unable to do so. */
76a01679 5258
4c4b4cd2 5259 if (current_block == NULL)
54d343a2 5260 return syms->size ();
76a01679 5261
7f0df278 5262 current_function = block_linkage_function (current_block);
4c4b4cd2 5263 if (current_function == NULL)
54d343a2 5264 return syms->size ();
4c4b4cd2
PH
5265
5266 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5267 if (current_function_name == NULL)
54d343a2 5268 return syms->size ();
4c4b4cd2
PH
5269
5270 /* Check each of the symbols, and remove it from the list if it is
5271 a type corresponding to a renaming that is out of the scope of
5272 the current block. */
5273
5274 i = 0;
54d343a2 5275 while (i < syms->size ())
4c4b4cd2 5276 {
54d343a2 5277 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
aeb5907d 5278 == ADA_OBJECT_RENAMING
54d343a2
TT
5279 && old_renaming_is_invisible ((*syms)[i].symbol,
5280 current_function_name))
5281 syms->erase (syms->begin () + i);
4c4b4cd2
PH
5282 else
5283 i += 1;
5284 }
5285
54d343a2 5286 return syms->size ();
4c4b4cd2
PH
5287}
5288
339c13b6
JB
5289/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5290 whose name and domain match NAME and DOMAIN respectively.
5291 If no match was found, then extend the search to "enclosing"
5292 routines (in other words, if we're inside a nested function,
5293 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5294 If WILD_MATCH_P is nonzero, perform the naming matching in
5295 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5296
5297 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5298
5299static void
b5ec771e
PA
5300ada_add_local_symbols (struct obstack *obstackp,
5301 const lookup_name_info &lookup_name,
5302 const struct block *block, domain_enum domain)
339c13b6
JB
5303{
5304 int block_depth = 0;
5305
5306 while (block != NULL)
5307 {
5308 block_depth += 1;
b5ec771e 5309 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5310
5311 /* If we found a non-function match, assume that's the one. */
5312 if (is_nonfunction (defns_collected (obstackp, 0),
5313 num_defns_collected (obstackp)))
5314 return;
5315
5316 block = BLOCK_SUPERBLOCK (block);
5317 }
5318
5319 /* If no luck so far, try to find NAME as a local symbol in some lexically
5320 enclosing subprogram. */
5321 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5322 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5323}
5324
ccefe4c4 5325/* An object of this type is used as the user_data argument when
40658b94 5326 calling the map_matching_symbols method. */
ccefe4c4 5327
40658b94 5328struct match_data
ccefe4c4 5329{
40658b94 5330 struct objfile *objfile;
ccefe4c4 5331 struct obstack *obstackp;
40658b94
PH
5332 struct symbol *arg_sym;
5333 int found_sym;
ccefe4c4
TT
5334};
5335
22cee43f 5336/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5337 to a list of symbols. DATA0 is a pointer to a struct match_data *
5338 containing the obstack that collects the symbol list, the file that SYM
5339 must come from, a flag indicating whether a non-argument symbol has
5340 been found in the current block, and the last argument symbol
5341 passed in SYM within the current block (if any). When SYM is null,
5342 marking the end of a block, the argument symbol is added if no
5343 other has been found. */
ccefe4c4 5344
40658b94 5345static int
582942f4
TT
5346aux_add_nonlocal_symbols (const struct block *block, struct symbol *sym,
5347 void *data0)
ccefe4c4 5348{
40658b94
PH
5349 struct match_data *data = (struct match_data *) data0;
5350
5351 if (sym == NULL)
5352 {
5353 if (!data->found_sym && data->arg_sym != NULL)
5354 add_defn_to_vec (data->obstackp,
5355 fixup_symbol_section (data->arg_sym, data->objfile),
5356 block);
5357 data->found_sym = 0;
5358 data->arg_sym = NULL;
5359 }
5360 else
5361 {
5362 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5363 return 0;
5364 else if (SYMBOL_IS_ARGUMENT (sym))
5365 data->arg_sym = sym;
5366 else
5367 {
5368 data->found_sym = 1;
5369 add_defn_to_vec (data->obstackp,
5370 fixup_symbol_section (sym, data->objfile),
5371 block);
5372 }
5373 }
5374 return 0;
5375}
5376
b5ec771e
PA
5377/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5378 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5379 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5380
5381static int
5382ada_add_block_renamings (struct obstack *obstackp,
5383 const struct block *block,
b5ec771e
PA
5384 const lookup_name_info &lookup_name,
5385 domain_enum domain)
22cee43f
PMR
5386{
5387 struct using_direct *renaming;
5388 int defns_mark = num_defns_collected (obstackp);
5389
b5ec771e
PA
5390 symbol_name_matcher_ftype *name_match
5391 = ada_get_symbol_name_matcher (lookup_name);
5392
22cee43f
PMR
5393 for (renaming = block_using (block);
5394 renaming != NULL;
5395 renaming = renaming->next)
5396 {
5397 const char *r_name;
22cee43f
PMR
5398
5399 /* Avoid infinite recursions: skip this renaming if we are actually
5400 already traversing it.
5401
5402 Currently, symbol lookup in Ada don't use the namespace machinery from
5403 C++/Fortran support: skip namespace imports that use them. */
5404 if (renaming->searched
5405 || (renaming->import_src != NULL
5406 && renaming->import_src[0] != '\0')
5407 || (renaming->import_dest != NULL
5408 && renaming->import_dest[0] != '\0'))
5409 continue;
5410 renaming->searched = 1;
5411
5412 /* TODO: here, we perform another name-based symbol lookup, which can
5413 pull its own multiple overloads. In theory, we should be able to do
5414 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5415 not a simple name. But in order to do this, we would need to enhance
5416 the DWARF reader to associate a symbol to this renaming, instead of a
5417 name. So, for now, we do something simpler: re-use the C++/Fortran
5418 namespace machinery. */
5419 r_name = (renaming->alias != NULL
5420 ? renaming->alias
5421 : renaming->declaration);
b5ec771e
PA
5422 if (name_match (r_name, lookup_name, NULL))
5423 {
5424 lookup_name_info decl_lookup_name (renaming->declaration,
5425 lookup_name.match_type ());
5426 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5427 1, NULL);
5428 }
22cee43f
PMR
5429 renaming->searched = 0;
5430 }
5431 return num_defns_collected (obstackp) != defns_mark;
5432}
5433
db230ce3
JB
5434/* Implements compare_names, but only applying the comparision using
5435 the given CASING. */
5b4ee69b 5436
40658b94 5437static int
db230ce3
JB
5438compare_names_with_case (const char *string1, const char *string2,
5439 enum case_sensitivity casing)
40658b94
PH
5440{
5441 while (*string1 != '\0' && *string2 != '\0')
5442 {
db230ce3
JB
5443 char c1, c2;
5444
40658b94
PH
5445 if (isspace (*string1) || isspace (*string2))
5446 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5447
5448 if (casing == case_sensitive_off)
5449 {
5450 c1 = tolower (*string1);
5451 c2 = tolower (*string2);
5452 }
5453 else
5454 {
5455 c1 = *string1;
5456 c2 = *string2;
5457 }
5458 if (c1 != c2)
40658b94 5459 break;
db230ce3 5460
40658b94
PH
5461 string1 += 1;
5462 string2 += 1;
5463 }
db230ce3 5464
40658b94
PH
5465 switch (*string1)
5466 {
5467 case '(':
5468 return strcmp_iw_ordered (string1, string2);
5469 case '_':
5470 if (*string2 == '\0')
5471 {
052874e8 5472 if (is_name_suffix (string1))
40658b94
PH
5473 return 0;
5474 else
1a1d5513 5475 return 1;
40658b94 5476 }
dbb8534f 5477 /* FALLTHROUGH */
40658b94
PH
5478 default:
5479 if (*string2 == '(')
5480 return strcmp_iw_ordered (string1, string2);
5481 else
db230ce3
JB
5482 {
5483 if (casing == case_sensitive_off)
5484 return tolower (*string1) - tolower (*string2);
5485 else
5486 return *string1 - *string2;
5487 }
40658b94 5488 }
ccefe4c4
TT
5489}
5490
db230ce3
JB
5491/* Compare STRING1 to STRING2, with results as for strcmp.
5492 Compatible with strcmp_iw_ordered in that...
5493
5494 strcmp_iw_ordered (STRING1, STRING2) <= 0
5495
5496 ... implies...
5497
5498 compare_names (STRING1, STRING2) <= 0
5499
5500 (they may differ as to what symbols compare equal). */
5501
5502static int
5503compare_names (const char *string1, const char *string2)
5504{
5505 int result;
5506
5507 /* Similar to what strcmp_iw_ordered does, we need to perform
5508 a case-insensitive comparison first, and only resort to
5509 a second, case-sensitive, comparison if the first one was
5510 not sufficient to differentiate the two strings. */
5511
5512 result = compare_names_with_case (string1, string2, case_sensitive_off);
5513 if (result == 0)
5514 result = compare_names_with_case (string1, string2, case_sensitive_on);
5515
5516 return result;
5517}
5518
b5ec771e
PA
5519/* Convenience function to get at the Ada encoded lookup name for
5520 LOOKUP_NAME, as a C string. */
5521
5522static const char *
5523ada_lookup_name (const lookup_name_info &lookup_name)
5524{
5525 return lookup_name.ada ().lookup_name ().c_str ();
5526}
5527
339c13b6 5528/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5529 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5530 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5531 symbols otherwise. */
339c13b6
JB
5532
5533static void
b5ec771e
PA
5534add_nonlocal_symbols (struct obstack *obstackp,
5535 const lookup_name_info &lookup_name,
5536 domain_enum domain, int global)
339c13b6 5537{
40658b94 5538 struct match_data data;
339c13b6 5539
6475f2fe 5540 memset (&data, 0, sizeof data);
ccefe4c4 5541 data.obstackp = obstackp;
339c13b6 5542
b5ec771e
PA
5543 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5544
2030c079 5545 for (objfile *objfile : current_program_space->objfiles ())
40658b94
PH
5546 {
5547 data.objfile = objfile;
5548
5549 if (is_wild_match)
b5ec771e
PA
5550 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5551 domain, global,
4186eb54 5552 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5553 symbol_name_match_type::WILD,
5554 NULL);
40658b94 5555 else
b5ec771e
PA
5556 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5557 domain, global,
4186eb54 5558 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5559 symbol_name_match_type::FULL,
5560 compare_names);
22cee43f 5561
b669c953 5562 for (compunit_symtab *cu : objfile->compunits ())
22cee43f
PMR
5563 {
5564 const struct block *global_block
5565 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5566
b5ec771e
PA
5567 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5568 domain))
22cee43f
PMR
5569 data.found_sym = 1;
5570 }
40658b94
PH
5571 }
5572
5573 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5574 {
b5ec771e
PA
5575 const char *name = ada_lookup_name (lookup_name);
5576 std::string name1 = std::string ("<_ada_") + name + '>';
5577
2030c079 5578 for (objfile *objfile : current_program_space->objfiles ())
40658b94 5579 {
40658b94 5580 data.objfile = objfile;
b5ec771e
PA
5581 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5582 domain, global,
0963b4bd
MS
5583 aux_add_nonlocal_symbols,
5584 &data,
b5ec771e
PA
5585 symbol_name_match_type::FULL,
5586 compare_names);
40658b94
PH
5587 }
5588 }
339c13b6
JB
5589}
5590
b5ec771e
PA
5591/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5592 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5593 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5594
22cee43f
PMR
5595 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5596 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5597 is the one match returned (no other matches in that or
d9680e73 5598 enclosing blocks is returned). If there are any matches in or
22cee43f 5599 surrounding BLOCK, then these alone are returned.
4eeaa230 5600
b5ec771e
PA
5601 Names prefixed with "standard__" are handled specially:
5602 "standard__" is first stripped off (by the lookup_name
5603 constructor), and only static and global symbols are searched.
14f9c5c9 5604
22cee43f
PMR
5605 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5606 to lookup global symbols. */
5607
5608static void
5609ada_add_all_symbols (struct obstack *obstackp,
5610 const struct block *block,
b5ec771e 5611 const lookup_name_info &lookup_name,
22cee43f
PMR
5612 domain_enum domain,
5613 int full_search,
5614 int *made_global_lookup_p)
14f9c5c9
AS
5615{
5616 struct symbol *sym;
14f9c5c9 5617
22cee43f
PMR
5618 if (made_global_lookup_p)
5619 *made_global_lookup_p = 0;
339c13b6
JB
5620
5621 /* Special case: If the user specifies a symbol name inside package
5622 Standard, do a non-wild matching of the symbol name without
5623 the "standard__" prefix. This was primarily introduced in order
5624 to allow the user to specifically access the standard exceptions
5625 using, for instance, Standard.Constraint_Error when Constraint_Error
5626 is ambiguous (due to the user defining its own Constraint_Error
5627 entity inside its program). */
b5ec771e
PA
5628 if (lookup_name.ada ().standard_p ())
5629 block = NULL;
4c4b4cd2 5630
339c13b6 5631 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5632
4eeaa230
DE
5633 if (block != NULL)
5634 {
5635 if (full_search)
b5ec771e 5636 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5637 else
5638 {
5639 /* In the !full_search case we're are being called by
5640 ada_iterate_over_symbols, and we don't want to search
5641 superblocks. */
b5ec771e 5642 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5643 }
22cee43f
PMR
5644 if (num_defns_collected (obstackp) > 0 || !full_search)
5645 return;
4eeaa230 5646 }
d2e4a39e 5647
339c13b6
JB
5648 /* No non-global symbols found. Check our cache to see if we have
5649 already performed this search before. If we have, then return
5650 the same result. */
5651
b5ec771e
PA
5652 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5653 domain, &sym, &block))
4c4b4cd2
PH
5654 {
5655 if (sym != NULL)
b5ec771e 5656 add_defn_to_vec (obstackp, sym, block);
22cee43f 5657 return;
4c4b4cd2 5658 }
14f9c5c9 5659
22cee43f
PMR
5660 if (made_global_lookup_p)
5661 *made_global_lookup_p = 1;
b1eedac9 5662
339c13b6
JB
5663 /* Search symbols from all global blocks. */
5664
b5ec771e 5665 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5666
4c4b4cd2 5667 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5668 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5669
22cee43f 5670 if (num_defns_collected (obstackp) == 0)
b5ec771e 5671 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5672}
5673
b5ec771e
PA
5674/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5675 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5676 matches.
54d343a2
TT
5677 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5678 found and the blocks and symbol tables (if any) in which they were
5679 found.
22cee43f
PMR
5680
5681 When full_search is non-zero, any non-function/non-enumeral
5682 symbol match within the nest of blocks whose innermost member is BLOCK,
5683 is the one match returned (no other matches in that or
5684 enclosing blocks is returned). If there are any matches in or
5685 surrounding BLOCK, then these alone are returned.
5686
5687 Names prefixed with "standard__" are handled specially: "standard__"
5688 is first stripped off, and only static and global symbols are searched. */
5689
5690static int
b5ec771e
PA
5691ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5692 const struct block *block,
22cee43f 5693 domain_enum domain,
54d343a2 5694 std::vector<struct block_symbol> *results,
22cee43f
PMR
5695 int full_search)
5696{
22cee43f
PMR
5697 int syms_from_global_search;
5698 int ndefns;
ec6a20c2 5699 auto_obstack obstack;
22cee43f 5700
ec6a20c2 5701 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5702 domain, full_search, &syms_from_global_search);
14f9c5c9 5703
ec6a20c2
JB
5704 ndefns = num_defns_collected (&obstack);
5705
54d343a2
TT
5706 struct block_symbol *base = defns_collected (&obstack, 1);
5707 for (int i = 0; i < ndefns; ++i)
5708 results->push_back (base[i]);
4c4b4cd2 5709
54d343a2 5710 ndefns = remove_extra_symbols (results);
4c4b4cd2 5711
b1eedac9 5712 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5713 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5714
b1eedac9 5715 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5716 cache_symbol (ada_lookup_name (lookup_name), domain,
5717 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5718
54d343a2 5719 ndefns = remove_irrelevant_renamings (results, block);
ec6a20c2 5720
14f9c5c9
AS
5721 return ndefns;
5722}
5723
b5ec771e 5724/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
54d343a2
TT
5725 in global scopes, returning the number of matches, and filling *RESULTS
5726 with (SYM,BLOCK) tuples.
ec6a20c2 5727
4eeaa230
DE
5728 See ada_lookup_symbol_list_worker for further details. */
5729
5730int
b5ec771e 5731ada_lookup_symbol_list (const char *name, const struct block *block,
54d343a2
TT
5732 domain_enum domain,
5733 std::vector<struct block_symbol> *results)
4eeaa230 5734{
b5ec771e
PA
5735 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5736 lookup_name_info lookup_name (name, name_match_type);
5737
5738 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5739}
5740
5741/* Implementation of the la_iterate_over_symbols method. */
5742
5743static void
14bc53a8 5744ada_iterate_over_symbols
b5ec771e
PA
5745 (const struct block *block, const lookup_name_info &name,
5746 domain_enum domain,
14bc53a8 5747 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5748{
5749 int ndefs, i;
54d343a2 5750 std::vector<struct block_symbol> results;
4eeaa230
DE
5751
5752 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2 5753
4eeaa230
DE
5754 for (i = 0; i < ndefs; ++i)
5755 {
7e41c8db 5756 if (!callback (&results[i]))
4eeaa230
DE
5757 break;
5758 }
5759}
5760
4e5c77fe
JB
5761/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5762 to 1, but choosing the first symbol found if there are multiple
5763 choices.
5764
5e2336be
JB
5765 The result is stored in *INFO, which must be non-NULL.
5766 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5767
5768void
5769ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5770 domain_enum domain,
d12307c1 5771 struct block_symbol *info)
14f9c5c9 5772{
b5ec771e
PA
5773 /* Since we already have an encoded name, wrap it in '<>' to force a
5774 verbatim match. Otherwise, if the name happens to not look like
5775 an encoded name (because it doesn't include a "__"),
5776 ada_lookup_name_info would re-encode/fold it again, and that
5777 would e.g., incorrectly lowercase object renaming names like
5778 "R28b" -> "r28b". */
5779 std::string verbatim = std::string ("<") + name + '>';
5780
5e2336be 5781 gdb_assert (info != NULL);
f98fc17b 5782 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5783}
aeb5907d
JB
5784
5785/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5786 scope and in global scopes, or NULL if none. NAME is folded and
5787 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5788 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5789 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5790
d12307c1 5791struct block_symbol
aeb5907d 5792ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5793 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5794{
5795 if (is_a_field_of_this != NULL)
5796 *is_a_field_of_this = 0;
5797
54d343a2 5798 std::vector<struct block_symbol> candidates;
f98fc17b 5799 int n_candidates;
f98fc17b
PA
5800
5801 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
f98fc17b
PA
5802
5803 if (n_candidates == 0)
54d343a2 5804 return {};
f98fc17b
PA
5805
5806 block_symbol info = candidates[0];
5807 info.symbol = fixup_symbol_section (info.symbol, NULL);
d12307c1 5808 return info;
4c4b4cd2 5809}
14f9c5c9 5810
d12307c1 5811static struct block_symbol
f606139a
DE
5812ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5813 const char *name,
76a01679 5814 const struct block *block,
21b556f4 5815 const domain_enum domain)
4c4b4cd2 5816{
d12307c1 5817 struct block_symbol sym;
04dccad0
JB
5818
5819 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5820 if (sym.symbol != NULL)
04dccad0
JB
5821 return sym;
5822
5823 /* If we haven't found a match at this point, try the primitive
5824 types. In other languages, this search is performed before
5825 searching for global symbols in order to short-circuit that
5826 global-symbol search if it happens that the name corresponds
5827 to a primitive type. But we cannot do the same in Ada, because
5828 it is perfectly legitimate for a program to declare a type which
5829 has the same name as a standard type. If looking up a type in
5830 that situation, we have traditionally ignored the primitive type
5831 in favor of user-defined types. This is why, unlike most other
5832 languages, we search the primitive types this late and only after
5833 having searched the global symbols without success. */
5834
5835 if (domain == VAR_DOMAIN)
5836 {
5837 struct gdbarch *gdbarch;
5838
5839 if (block == NULL)
5840 gdbarch = target_gdbarch ();
5841 else
5842 gdbarch = block_gdbarch (block);
d12307c1
PMR
5843 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5844 if (sym.symbol != NULL)
04dccad0
JB
5845 return sym;
5846 }
5847
6640a367 5848 return {};
14f9c5c9
AS
5849}
5850
5851
4c4b4cd2
PH
5852/* True iff STR is a possible encoded suffix of a normal Ada name
5853 that is to be ignored for matching purposes. Suffixes of parallel
5854 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5855 are given by any of the regular expressions:
4c4b4cd2 5856
babe1480
JB
5857 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5858 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5859 TKB [subprogram suffix for task bodies]
babe1480 5860 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5861 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5862
5863 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5864 match is performed. This sequence is used to differentiate homonyms,
5865 is an optional part of a valid name suffix. */
4c4b4cd2 5866
14f9c5c9 5867static int
d2e4a39e 5868is_name_suffix (const char *str)
14f9c5c9
AS
5869{
5870 int k;
4c4b4cd2
PH
5871 const char *matching;
5872 const int len = strlen (str);
5873
babe1480
JB
5874 /* Skip optional leading __[0-9]+. */
5875
4c4b4cd2
PH
5876 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5877 {
babe1480
JB
5878 str += 3;
5879 while (isdigit (str[0]))
5880 str += 1;
4c4b4cd2 5881 }
babe1480
JB
5882
5883 /* [.$][0-9]+ */
4c4b4cd2 5884
babe1480 5885 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5886 {
babe1480 5887 matching = str + 1;
4c4b4cd2
PH
5888 while (isdigit (matching[0]))
5889 matching += 1;
5890 if (matching[0] == '\0')
5891 return 1;
5892 }
5893
5894 /* ___[0-9]+ */
babe1480 5895
4c4b4cd2
PH
5896 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5897 {
5898 matching = str + 3;
5899 while (isdigit (matching[0]))
5900 matching += 1;
5901 if (matching[0] == '\0')
5902 return 1;
5903 }
5904
9ac7f98e
JB
5905 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5906
5907 if (strcmp (str, "TKB") == 0)
5908 return 1;
5909
529cad9c
PH
5910#if 0
5911 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5912 with a N at the end. Unfortunately, the compiler uses the same
5913 convention for other internal types it creates. So treating
529cad9c 5914 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5915 some regressions. For instance, consider the case of an enumerated
5916 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5917 name ends with N.
5918 Having a single character like this as a suffix carrying some
0963b4bd 5919 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5920 to be something like "_N" instead. In the meantime, do not do
5921 the following check. */
5922 /* Protected Object Subprograms */
5923 if (len == 1 && str [0] == 'N')
5924 return 1;
5925#endif
5926
5927 /* _E[0-9]+[bs]$ */
5928 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5929 {
5930 matching = str + 3;
5931 while (isdigit (matching[0]))
5932 matching += 1;
5933 if ((matching[0] == 'b' || matching[0] == 's')
5934 && matching [1] == '\0')
5935 return 1;
5936 }
5937
4c4b4cd2
PH
5938 /* ??? We should not modify STR directly, as we are doing below. This
5939 is fine in this case, but may become problematic later if we find
5940 that this alternative did not work, and want to try matching
5941 another one from the begining of STR. Since we modified it, we
5942 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5943 if (str[0] == 'X')
5944 {
5945 str += 1;
d2e4a39e 5946 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5947 {
5948 if (str[0] != 'n' && str[0] != 'b')
5949 return 0;
5950 str += 1;
5951 }
14f9c5c9 5952 }
babe1480 5953
14f9c5c9
AS
5954 if (str[0] == '\000')
5955 return 1;
babe1480 5956
d2e4a39e 5957 if (str[0] == '_')
14f9c5c9
AS
5958 {
5959 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5960 return 0;
d2e4a39e 5961 if (str[2] == '_')
4c4b4cd2 5962 {
61ee279c
PH
5963 if (strcmp (str + 3, "JM") == 0)
5964 return 1;
5965 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5966 the LJM suffix in favor of the JM one. But we will
5967 still accept LJM as a valid suffix for a reasonable
5968 amount of time, just to allow ourselves to debug programs
5969 compiled using an older version of GNAT. */
4c4b4cd2
PH
5970 if (strcmp (str + 3, "LJM") == 0)
5971 return 1;
5972 if (str[3] != 'X')
5973 return 0;
1265e4aa
JB
5974 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5975 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5976 return 1;
5977 if (str[4] == 'R' && str[5] != 'T')
5978 return 1;
5979 return 0;
5980 }
5981 if (!isdigit (str[2]))
5982 return 0;
5983 for (k = 3; str[k] != '\0'; k += 1)
5984 if (!isdigit (str[k]) && str[k] != '_')
5985 return 0;
14f9c5c9
AS
5986 return 1;
5987 }
4c4b4cd2 5988 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5989 {
4c4b4cd2
PH
5990 for (k = 2; str[k] != '\0'; k += 1)
5991 if (!isdigit (str[k]) && str[k] != '_')
5992 return 0;
14f9c5c9
AS
5993 return 1;
5994 }
5995 return 0;
5996}
d2e4a39e 5997
aeb5907d
JB
5998/* Return non-zero if the string starting at NAME and ending before
5999 NAME_END contains no capital letters. */
529cad9c
PH
6000
6001static int
6002is_valid_name_for_wild_match (const char *name0)
6003{
6004 const char *decoded_name = ada_decode (name0);
6005 int i;
6006
5823c3ef
JB
6007 /* If the decoded name starts with an angle bracket, it means that
6008 NAME0 does not follow the GNAT encoding format. It should then
6009 not be allowed as a possible wild match. */
6010 if (decoded_name[0] == '<')
6011 return 0;
6012
529cad9c
PH
6013 for (i=0; decoded_name[i] != '\0'; i++)
6014 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6015 return 0;
6016
6017 return 1;
6018}
6019
73589123
PH
6020/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6021 that could start a simple name. Assumes that *NAMEP points into
6022 the string beginning at NAME0. */
4c4b4cd2 6023
14f9c5c9 6024static int
73589123 6025advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6026{
73589123 6027 const char *name = *namep;
5b4ee69b 6028
5823c3ef 6029 while (1)
14f9c5c9 6030 {
aa27d0b3 6031 int t0, t1;
73589123
PH
6032
6033 t0 = *name;
6034 if (t0 == '_')
6035 {
6036 t1 = name[1];
6037 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6038 {
6039 name += 1;
61012eef 6040 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6041 break;
6042 else
6043 name += 1;
6044 }
aa27d0b3
JB
6045 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6046 || name[2] == target0))
73589123
PH
6047 {
6048 name += 2;
6049 break;
6050 }
6051 else
6052 return 0;
6053 }
6054 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6055 name += 1;
6056 else
5823c3ef 6057 return 0;
73589123
PH
6058 }
6059
6060 *namep = name;
6061 return 1;
6062}
6063
b5ec771e
PA
6064/* Return true iff NAME encodes a name of the form prefix.PATN.
6065 Ignores any informational suffixes of NAME (i.e., for which
6066 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6067 simple name. */
73589123 6068
b5ec771e 6069static bool
73589123
PH
6070wild_match (const char *name, const char *patn)
6071{
22e048c9 6072 const char *p;
73589123
PH
6073 const char *name0 = name;
6074
6075 while (1)
6076 {
6077 const char *match = name;
6078
6079 if (*name == *patn)
6080 {
6081 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6082 if (*p != *name)
6083 break;
6084 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6085 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6086
6087 if (name[-1] == '_')
6088 name -= 1;
6089 }
6090 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6091 return false;
96d887e8 6092 }
96d887e8
PH
6093}
6094
b5ec771e
PA
6095/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6096 any trailing suffixes that encode debugging information or leading
6097 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6098 information that is ignored). */
40658b94 6099
b5ec771e 6100static bool
c4d840bd
PH
6101full_match (const char *sym_name, const char *search_name)
6102{
b5ec771e
PA
6103 size_t search_name_len = strlen (search_name);
6104
6105 if (strncmp (sym_name, search_name, search_name_len) == 0
6106 && is_name_suffix (sym_name + search_name_len))
6107 return true;
6108
6109 if (startswith (sym_name, "_ada_")
6110 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6111 && is_name_suffix (sym_name + search_name_len + 5))
6112 return true;
c4d840bd 6113
b5ec771e
PA
6114 return false;
6115}
c4d840bd 6116
b5ec771e
PA
6117/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6118 *defn_symbols, updating the list of symbols in OBSTACKP (if
6119 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6120
6121static void
6122ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6123 const struct block *block,
6124 const lookup_name_info &lookup_name,
6125 domain_enum domain, struct objfile *objfile)
96d887e8 6126{
8157b174 6127 struct block_iterator iter;
96d887e8
PH
6128 /* A matching argument symbol, if any. */
6129 struct symbol *arg_sym;
6130 /* Set true when we find a matching non-argument symbol. */
6131 int found_sym;
6132 struct symbol *sym;
6133
6134 arg_sym = NULL;
6135 found_sym = 0;
b5ec771e
PA
6136 for (sym = block_iter_match_first (block, lookup_name, &iter);
6137 sym != NULL;
6138 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6139 {
b5ec771e
PA
6140 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6141 SYMBOL_DOMAIN (sym), domain))
6142 {
6143 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6144 {
6145 if (SYMBOL_IS_ARGUMENT (sym))
6146 arg_sym = sym;
6147 else
6148 {
6149 found_sym = 1;
6150 add_defn_to_vec (obstackp,
6151 fixup_symbol_section (sym, objfile),
6152 block);
6153 }
6154 }
6155 }
96d887e8
PH
6156 }
6157
22cee43f
PMR
6158 /* Handle renamings. */
6159
b5ec771e 6160 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6161 found_sym = 1;
6162
96d887e8
PH
6163 if (!found_sym && arg_sym != NULL)
6164 {
76a01679
JB
6165 add_defn_to_vec (obstackp,
6166 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6167 block);
96d887e8
PH
6168 }
6169
b5ec771e 6170 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6171 {
6172 arg_sym = NULL;
6173 found_sym = 0;
b5ec771e
PA
6174 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6175 const char *name = ada_lookup_name.c_str ();
6176 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6177
6178 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6179 {
4186eb54
KS
6180 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6181 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6182 {
6183 int cmp;
6184
6185 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6186 if (cmp == 0)
6187 {
61012eef 6188 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6189 if (cmp == 0)
6190 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6191 name_len);
6192 }
6193
6194 if (cmp == 0
6195 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6196 {
2a2d4dc3
AS
6197 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6198 {
6199 if (SYMBOL_IS_ARGUMENT (sym))
6200 arg_sym = sym;
6201 else
6202 {
6203 found_sym = 1;
6204 add_defn_to_vec (obstackp,
6205 fixup_symbol_section (sym, objfile),
6206 block);
6207 }
6208 }
76a01679
JB
6209 }
6210 }
76a01679 6211 }
96d887e8
PH
6212
6213 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6214 They aren't parameters, right? */
6215 if (!found_sym && arg_sym != NULL)
6216 {
6217 add_defn_to_vec (obstackp,
76a01679 6218 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6219 block);
96d887e8
PH
6220 }
6221 }
6222}
6223\f
41d27058
JB
6224
6225 /* Symbol Completion */
6226
b5ec771e 6227/* See symtab.h. */
41d27058 6228
b5ec771e
PA
6229bool
6230ada_lookup_name_info::matches
6231 (const char *sym_name,
6232 symbol_name_match_type match_type,
a207cff2 6233 completion_match_result *comp_match_res) const
41d27058 6234{
b5ec771e
PA
6235 bool match = false;
6236 const char *text = m_encoded_name.c_str ();
6237 size_t text_len = m_encoded_name.size ();
41d27058
JB
6238
6239 /* First, test against the fully qualified name of the symbol. */
6240
6241 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6242 match = true;
41d27058 6243
b5ec771e 6244 if (match && !m_encoded_p)
41d27058
JB
6245 {
6246 /* One needed check before declaring a positive match is to verify
6247 that iff we are doing a verbatim match, the decoded version
6248 of the symbol name starts with '<'. Otherwise, this symbol name
6249 is not a suitable completion. */
6250 const char *sym_name_copy = sym_name;
b5ec771e 6251 bool has_angle_bracket;
41d27058
JB
6252
6253 sym_name = ada_decode (sym_name);
6254 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6255 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6256 sym_name = sym_name_copy;
6257 }
6258
b5ec771e 6259 if (match && !m_verbatim_p)
41d27058
JB
6260 {
6261 /* When doing non-verbatim match, another check that needs to
6262 be done is to verify that the potentially matching symbol name
6263 does not include capital letters, because the ada-mode would
6264 not be able to understand these symbol names without the
6265 angle bracket notation. */
6266 const char *tmp;
6267
6268 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6269 if (*tmp != '\0')
b5ec771e 6270 match = false;
41d27058
JB
6271 }
6272
6273 /* Second: Try wild matching... */
6274
b5ec771e 6275 if (!match && m_wild_match_p)
41d27058
JB
6276 {
6277 /* Since we are doing wild matching, this means that TEXT
6278 may represent an unqualified symbol name. We therefore must
6279 also compare TEXT against the unqualified name of the symbol. */
6280 sym_name = ada_unqualified_name (ada_decode (sym_name));
6281
6282 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6283 match = true;
41d27058
JB
6284 }
6285
b5ec771e 6286 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6287
6288 if (!match)
b5ec771e 6289 return false;
41d27058 6290
a207cff2 6291 if (comp_match_res != NULL)
b5ec771e 6292 {
a207cff2 6293 std::string &match_str = comp_match_res->match.storage ();
41d27058 6294
b5ec771e 6295 if (!m_encoded_p)
a207cff2 6296 match_str = ada_decode (sym_name);
b5ec771e
PA
6297 else
6298 {
6299 if (m_verbatim_p)
6300 match_str = add_angle_brackets (sym_name);
6301 else
6302 match_str = sym_name;
41d27058 6303
b5ec771e 6304 }
a207cff2
PA
6305
6306 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6307 }
6308
b5ec771e 6309 return true;
41d27058
JB
6310}
6311
b5ec771e 6312/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6313 WORD is the entire command on which completion is made. */
41d27058 6314
eb3ff9a5
PA
6315static void
6316ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6317 complete_symbol_mode mode,
b5ec771e
PA
6318 symbol_name_match_type name_match_type,
6319 const char *text, const char *word,
eb3ff9a5 6320 enum type_code code)
41d27058 6321{
41d27058 6322 struct symbol *sym;
3977b71f 6323 const struct block *b, *surrounding_static_block = 0;
8157b174 6324 struct block_iterator iter;
41d27058 6325
2f68a895
TT
6326 gdb_assert (code == TYPE_CODE_UNDEF);
6327
1b026119 6328 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6329
6330 /* First, look at the partial symtab symbols. */
14bc53a8 6331 expand_symtabs_matching (NULL,
b5ec771e
PA
6332 lookup_name,
6333 NULL,
14bc53a8
PA
6334 NULL,
6335 ALL_DOMAIN);
41d27058
JB
6336
6337 /* At this point scan through the misc symbol vectors and add each
6338 symbol you find to the list. Eventually we want to ignore
6339 anything that isn't a text symbol (everything else will be
6340 handled by the psymtab code above). */
6341
2030c079 6342 for (objfile *objfile : current_program_space->objfiles ())
5325b9bf 6343 {
7932255d 6344 for (minimal_symbol *msymbol : objfile->msymbols ())
5325b9bf
TT
6345 {
6346 QUIT;
6347
6348 if (completion_skip_symbol (mode, msymbol))
6349 continue;
6350
6351 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6352
6353 /* Ada minimal symbols won't have their language set to Ada. If
6354 we let completion_list_add_name compare using the
6355 default/C-like matcher, then when completing e.g., symbols in a
6356 package named "pck", we'd match internal Ada symbols like
6357 "pckS", which are invalid in an Ada expression, unless you wrap
6358 them in '<' '>' to request a verbatim match.
6359
6360 Unfortunately, some Ada encoded names successfully demangle as
6361 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6362 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6363 with the wrong language set. Paper over that issue here. */
6364 if (symbol_language == language_auto
6365 || symbol_language == language_cplus)
6366 symbol_language = language_ada;
6367
6368 completion_list_add_name (tracker,
6369 symbol_language,
6370 MSYMBOL_LINKAGE_NAME (msymbol),
6371 lookup_name, text, word);
6372 }
6373 }
41d27058
JB
6374
6375 /* Search upwards from currently selected frame (so that we can
6376 complete on local vars. */
6377
6378 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6379 {
6380 if (!BLOCK_SUPERBLOCK (b))
6381 surrounding_static_block = b; /* For elmin of dups */
6382
6383 ALL_BLOCK_SYMBOLS (b, iter, sym)
6384 {
f9d67a22
PA
6385 if (completion_skip_symbol (mode, sym))
6386 continue;
6387
b5ec771e
PA
6388 completion_list_add_name (tracker,
6389 SYMBOL_LANGUAGE (sym),
6390 SYMBOL_LINKAGE_NAME (sym),
1b026119 6391 lookup_name, text, word);
41d27058
JB
6392 }
6393 }
6394
6395 /* Go through the symtabs and check the externs and statics for
43f3e411 6396 symbols which match. */
41d27058 6397
2030c079 6398 for (objfile *objfile : current_program_space->objfiles ())
41d27058 6399 {
b669c953 6400 for (compunit_symtab *s : objfile->compunits ())
d8aeb77f
TT
6401 {
6402 QUIT;
6403 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6404 ALL_BLOCK_SYMBOLS (b, iter, sym)
6405 {
6406 if (completion_skip_symbol (mode, sym))
6407 continue;
f9d67a22 6408
d8aeb77f
TT
6409 completion_list_add_name (tracker,
6410 SYMBOL_LANGUAGE (sym),
6411 SYMBOL_LINKAGE_NAME (sym),
6412 lookup_name, text, word);
6413 }
6414 }
41d27058 6415 }
41d27058 6416
2030c079 6417 for (objfile *objfile : current_program_space->objfiles ())
d8aeb77f 6418 {
b669c953 6419 for (compunit_symtab *s : objfile->compunits ())
d8aeb77f
TT
6420 {
6421 QUIT;
6422 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6423 /* Don't do this block twice. */
6424 if (b == surrounding_static_block)
6425 continue;
6426 ALL_BLOCK_SYMBOLS (b, iter, sym)
6427 {
6428 if (completion_skip_symbol (mode, sym))
6429 continue;
f9d67a22 6430
d8aeb77f
TT
6431 completion_list_add_name (tracker,
6432 SYMBOL_LANGUAGE (sym),
6433 SYMBOL_LINKAGE_NAME (sym),
6434 lookup_name, text, word);
6435 }
6436 }
41d27058 6437 }
41d27058
JB
6438}
6439
963a6417 6440 /* Field Access */
96d887e8 6441
73fb9985
JB
6442/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6443 for tagged types. */
6444
6445static int
6446ada_is_dispatch_table_ptr_type (struct type *type)
6447{
0d5cff50 6448 const char *name;
73fb9985
JB
6449
6450 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6451 return 0;
6452
6453 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6454 if (name == NULL)
6455 return 0;
6456
6457 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6458}
6459
ac4a2da4
JG
6460/* Return non-zero if TYPE is an interface tag. */
6461
6462static int
6463ada_is_interface_tag (struct type *type)
6464{
6465 const char *name = TYPE_NAME (type);
6466
6467 if (name == NULL)
6468 return 0;
6469
6470 return (strcmp (name, "ada__tags__interface_tag") == 0);
6471}
6472
963a6417
PH
6473/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6474 to be invisible to users. */
96d887e8 6475
963a6417
PH
6476int
6477ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6478{
963a6417
PH
6479 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6480 return 1;
ffde82bf 6481
73fb9985
JB
6482 /* Check the name of that field. */
6483 {
6484 const char *name = TYPE_FIELD_NAME (type, field_num);
6485
6486 /* Anonymous field names should not be printed.
6487 brobecker/2007-02-20: I don't think this can actually happen
6488 but we don't want to print the value of annonymous fields anyway. */
6489 if (name == NULL)
6490 return 1;
6491
ffde82bf
JB
6492 /* Normally, fields whose name start with an underscore ("_")
6493 are fields that have been internally generated by the compiler,
6494 and thus should not be printed. The "_parent" field is special,
6495 however: This is a field internally generated by the compiler
6496 for tagged types, and it contains the components inherited from
6497 the parent type. This field should not be printed as is, but
6498 should not be ignored either. */
61012eef 6499 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6500 return 1;
6501 }
6502
ac4a2da4
JG
6503 /* If this is the dispatch table of a tagged type or an interface tag,
6504 then ignore. */
73fb9985 6505 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6506 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6507 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6508 return 1;
6509
6510 /* Not a special field, so it should not be ignored. */
6511 return 0;
963a6417 6512}
96d887e8 6513
963a6417 6514/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6515 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6516
963a6417
PH
6517int
6518ada_is_tagged_type (struct type *type, int refok)
6519{
988f6b3d 6520 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6521}
96d887e8 6522
963a6417 6523/* True iff TYPE represents the type of X'Tag */
96d887e8 6524
963a6417
PH
6525int
6526ada_is_tag_type (struct type *type)
6527{
460efde1
JB
6528 type = ada_check_typedef (type);
6529
963a6417
PH
6530 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6531 return 0;
6532 else
96d887e8 6533 {
963a6417 6534 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6535
963a6417
PH
6536 return (name != NULL
6537 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6538 }
96d887e8
PH
6539}
6540
963a6417 6541/* The type of the tag on VAL. */
76a01679 6542
963a6417
PH
6543struct type *
6544ada_tag_type (struct value *val)
96d887e8 6545{
988f6b3d 6546 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6547}
96d887e8 6548
b50d69b5
JG
6549/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6550 retired at Ada 05). */
6551
6552static int
6553is_ada95_tag (struct value *tag)
6554{
6555 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6556}
6557
963a6417 6558/* The value of the tag on VAL. */
96d887e8 6559
963a6417
PH
6560struct value *
6561ada_value_tag (struct value *val)
6562{
03ee6b2e 6563 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6564}
6565
963a6417
PH
6566/* The value of the tag on the object of type TYPE whose contents are
6567 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6568 ADDRESS. */
96d887e8 6569
963a6417 6570static struct value *
10a2c479 6571value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6572 const gdb_byte *valaddr,
963a6417 6573 CORE_ADDR address)
96d887e8 6574{
b5385fc0 6575 int tag_byte_offset;
963a6417 6576 struct type *tag_type;
5b4ee69b 6577
963a6417 6578 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6579 NULL, NULL, NULL))
96d887e8 6580 {
fc1a4b47 6581 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6582 ? NULL
6583 : valaddr + tag_byte_offset);
963a6417 6584 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6585
963a6417 6586 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6587 }
963a6417
PH
6588 return NULL;
6589}
96d887e8 6590
963a6417
PH
6591static struct type *
6592type_from_tag (struct value *tag)
6593{
6594 const char *type_name = ada_tag_name (tag);
5b4ee69b 6595
963a6417
PH
6596 if (type_name != NULL)
6597 return ada_find_any_type (ada_encode (type_name));
6598 return NULL;
6599}
96d887e8 6600
b50d69b5
JG
6601/* Given a value OBJ of a tagged type, return a value of this
6602 type at the base address of the object. The base address, as
6603 defined in Ada.Tags, it is the address of the primary tag of
6604 the object, and therefore where the field values of its full
6605 view can be fetched. */
6606
6607struct value *
6608ada_tag_value_at_base_address (struct value *obj)
6609{
b50d69b5
JG
6610 struct value *val;
6611 LONGEST offset_to_top = 0;
6612 struct type *ptr_type, *obj_type;
6613 struct value *tag;
6614 CORE_ADDR base_address;
6615
6616 obj_type = value_type (obj);
6617
6618 /* It is the responsability of the caller to deref pointers. */
6619
6620 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6621 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6622 return obj;
6623
6624 tag = ada_value_tag (obj);
6625 if (!tag)
6626 return obj;
6627
6628 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6629
6630 if (is_ada95_tag (tag))
6631 return obj;
6632
08f49010
XR
6633 ptr_type = language_lookup_primitive_type
6634 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6635 ptr_type = lookup_pointer_type (ptr_type);
6636 val = value_cast (ptr_type, tag);
6637 if (!val)
6638 return obj;
6639
6640 /* It is perfectly possible that an exception be raised while
6641 trying to determine the base address, just like for the tag;
6642 see ada_tag_name for more details. We do not print the error
6643 message for the same reason. */
6644
a70b8144 6645 try
b50d69b5
JG
6646 {
6647 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6648 }
6649
230d2906 6650 catch (const gdb_exception_error &e)
492d29ea
PA
6651 {
6652 return obj;
6653 }
b50d69b5
JG
6654
6655 /* If offset is null, nothing to do. */
6656
6657 if (offset_to_top == 0)
6658 return obj;
6659
6660 /* -1 is a special case in Ada.Tags; however, what should be done
6661 is not quite clear from the documentation. So do nothing for
6662 now. */
6663
6664 if (offset_to_top == -1)
6665 return obj;
6666
08f49010
XR
6667 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6668 from the base address. This was however incompatible with
6669 C++ dispatch table: C++ uses a *negative* value to *add*
6670 to the base address. Ada's convention has therefore been
6671 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6672 use the same convention. Here, we support both cases by
6673 checking the sign of OFFSET_TO_TOP. */
6674
6675 if (offset_to_top > 0)
6676 offset_to_top = -offset_to_top;
6677
6678 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6679 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6680
6681 /* Make sure that we have a proper tag at the new address.
6682 Otherwise, offset_to_top is bogus (which can happen when
6683 the object is not initialized yet). */
6684
6685 if (!tag)
6686 return obj;
6687
6688 obj_type = type_from_tag (tag);
6689
6690 if (!obj_type)
6691 return obj;
6692
6693 return value_from_contents_and_address (obj_type, NULL, base_address);
6694}
6695
1b611343
JB
6696/* Return the "ada__tags__type_specific_data" type. */
6697
6698static struct type *
6699ada_get_tsd_type (struct inferior *inf)
963a6417 6700{
1b611343 6701 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6702
1b611343
JB
6703 if (data->tsd_type == 0)
6704 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6705 return data->tsd_type;
6706}
529cad9c 6707
1b611343
JB
6708/* Return the TSD (type-specific data) associated to the given TAG.
6709 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6710
1b611343 6711 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6712
1b611343
JB
6713static struct value *
6714ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6715{
4c4b4cd2 6716 struct value *val;
1b611343 6717 struct type *type;
5b4ee69b 6718
1b611343
JB
6719 /* First option: The TSD is simply stored as a field of our TAG.
6720 Only older versions of GNAT would use this format, but we have
6721 to test it first, because there are no visible markers for
6722 the current approach except the absence of that field. */
529cad9c 6723
1b611343
JB
6724 val = ada_value_struct_elt (tag, "tsd", 1);
6725 if (val)
6726 return val;
e802dbe0 6727
1b611343
JB
6728 /* Try the second representation for the dispatch table (in which
6729 there is no explicit 'tsd' field in the referent of the tag pointer,
6730 and instead the tsd pointer is stored just before the dispatch
6731 table. */
e802dbe0 6732
1b611343
JB
6733 type = ada_get_tsd_type (current_inferior());
6734 if (type == NULL)
6735 return NULL;
6736 type = lookup_pointer_type (lookup_pointer_type (type));
6737 val = value_cast (type, tag);
6738 if (val == NULL)
6739 return NULL;
6740 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6741}
6742
1b611343
JB
6743/* Given the TSD of a tag (type-specific data), return a string
6744 containing the name of the associated type.
6745
6746 The returned value is good until the next call. May return NULL
6747 if we are unable to determine the tag name. */
6748
6749static char *
6750ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6751{
529cad9c
PH
6752 static char name[1024];
6753 char *p;
1b611343 6754 struct value *val;
529cad9c 6755
1b611343 6756 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6757 if (val == NULL)
1b611343 6758 return NULL;
4c4b4cd2
PH
6759 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6760 for (p = name; *p != '\0'; p += 1)
6761 if (isalpha (*p))
6762 *p = tolower (*p);
1b611343 6763 return name;
4c4b4cd2
PH
6764}
6765
6766/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6767 a C string.
6768
6769 Return NULL if the TAG is not an Ada tag, or if we were unable to
6770 determine the name of that tag. The result is good until the next
6771 call. */
4c4b4cd2
PH
6772
6773const char *
6774ada_tag_name (struct value *tag)
6775{
1b611343 6776 char *name = NULL;
5b4ee69b 6777
df407dfe 6778 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6779 return NULL;
1b611343
JB
6780
6781 /* It is perfectly possible that an exception be raised while trying
6782 to determine the TAG's name, even under normal circumstances:
6783 The associated variable may be uninitialized or corrupted, for
6784 instance. We do not let any exception propagate past this point.
6785 instead we return NULL.
6786
6787 We also do not print the error message either (which often is very
6788 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6789 the caller print a more meaningful message if necessary. */
a70b8144 6790 try
1b611343
JB
6791 {
6792 struct value *tsd = ada_get_tsd_from_tag (tag);
6793
6794 if (tsd != NULL)
6795 name = ada_tag_name_from_tsd (tsd);
6796 }
230d2906 6797 catch (const gdb_exception_error &e)
492d29ea
PA
6798 {
6799 }
1b611343
JB
6800
6801 return name;
4c4b4cd2
PH
6802}
6803
6804/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6805
d2e4a39e 6806struct type *
ebf56fd3 6807ada_parent_type (struct type *type)
14f9c5c9
AS
6808{
6809 int i;
6810
61ee279c 6811 type = ada_check_typedef (type);
14f9c5c9
AS
6812
6813 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6814 return NULL;
6815
6816 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6817 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6818 {
6819 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6820
6821 /* If the _parent field is a pointer, then dereference it. */
6822 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6823 parent_type = TYPE_TARGET_TYPE (parent_type);
6824 /* If there is a parallel XVS type, get the actual base type. */
6825 parent_type = ada_get_base_type (parent_type);
6826
6827 return ada_check_typedef (parent_type);
6828 }
14f9c5c9
AS
6829
6830 return NULL;
6831}
6832
4c4b4cd2
PH
6833/* True iff field number FIELD_NUM of structure type TYPE contains the
6834 parent-type (inherited) fields of a derived type. Assumes TYPE is
6835 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6836
6837int
ebf56fd3 6838ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6839{
61ee279c 6840 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6841
4c4b4cd2 6842 return (name != NULL
61012eef
GB
6843 && (startswith (name, "PARENT")
6844 || startswith (name, "_parent")));
14f9c5c9
AS
6845}
6846
4c4b4cd2 6847/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6848 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6849 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6850 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6851 structures. */
14f9c5c9
AS
6852
6853int
ebf56fd3 6854ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6855{
d2e4a39e 6856 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6857
dddc0e16
JB
6858 if (name != NULL && strcmp (name, "RETVAL") == 0)
6859 {
6860 /* This happens in functions with "out" or "in out" parameters
6861 which are passed by copy. For such functions, GNAT describes
6862 the function's return type as being a struct where the return
6863 value is in a field called RETVAL, and where the other "out"
6864 or "in out" parameters are fields of that struct. This is not
6865 a wrapper. */
6866 return 0;
6867 }
6868
d2e4a39e 6869 return (name != NULL
61012eef 6870 && (startswith (name, "PARENT")
4c4b4cd2 6871 || strcmp (name, "REP") == 0
61012eef 6872 || startswith (name, "_parent")
4c4b4cd2 6873 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6874}
6875
4c4b4cd2
PH
6876/* True iff field number FIELD_NUM of structure or union type TYPE
6877 is a variant wrapper. Assumes TYPE is a structure type with at least
6878 FIELD_NUM+1 fields. */
14f9c5c9
AS
6879
6880int
ebf56fd3 6881ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6882{
8ecb59f8
TT
6883 /* Only Ada types are eligible. */
6884 if (!ADA_TYPE_P (type))
6885 return 0;
6886
d2e4a39e 6887 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6888
14f9c5c9 6889 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6890 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6891 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6892 == TYPE_CODE_UNION)));
14f9c5c9
AS
6893}
6894
6895/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6896 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6897 returns the type of the controlling discriminant for the variant.
6898 May return NULL if the type could not be found. */
14f9c5c9 6899
d2e4a39e 6900struct type *
ebf56fd3 6901ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6902{
a121b7c1 6903 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6904
988f6b3d 6905 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
6906}
6907
4c4b4cd2 6908/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6909 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6910 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6911
6912int
ebf56fd3 6913ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6914{
d2e4a39e 6915 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6916
14f9c5c9
AS
6917 return (name != NULL && name[0] == 'O');
6918}
6919
6920/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6921 returns the name of the discriminant controlling the variant.
6922 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6923
a121b7c1 6924const char *
ebf56fd3 6925ada_variant_discrim_name (struct type *type0)
14f9c5c9 6926{
d2e4a39e 6927 static char *result = NULL;
14f9c5c9 6928 static size_t result_len = 0;
d2e4a39e
AS
6929 struct type *type;
6930 const char *name;
6931 const char *discrim_end;
6932 const char *discrim_start;
14f9c5c9
AS
6933
6934 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6935 type = TYPE_TARGET_TYPE (type0);
6936 else
6937 type = type0;
6938
6939 name = ada_type_name (type);
6940
6941 if (name == NULL || name[0] == '\000')
6942 return "";
6943
6944 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6945 discrim_end -= 1)
6946 {
61012eef 6947 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 6948 break;
14f9c5c9
AS
6949 }
6950 if (discrim_end == name)
6951 return "";
6952
d2e4a39e 6953 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6954 discrim_start -= 1)
6955 {
d2e4a39e 6956 if (discrim_start == name + 1)
4c4b4cd2 6957 return "";
76a01679 6958 if ((discrim_start > name + 3
61012eef 6959 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
6960 || discrim_start[-1] == '.')
6961 break;
14f9c5c9
AS
6962 }
6963
6964 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6965 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6966 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6967 return result;
6968}
6969
4c4b4cd2
PH
6970/* Scan STR for a subtype-encoded number, beginning at position K.
6971 Put the position of the character just past the number scanned in
6972 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6973 Return 1 if there was a valid number at the given position, and 0
6974 otherwise. A "subtype-encoded" number consists of the absolute value
6975 in decimal, followed by the letter 'm' to indicate a negative number.
6976 Assumes 0m does not occur. */
14f9c5c9
AS
6977
6978int
d2e4a39e 6979ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6980{
6981 ULONGEST RU;
6982
d2e4a39e 6983 if (!isdigit (str[k]))
14f9c5c9
AS
6984 return 0;
6985
4c4b4cd2 6986 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6987 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6988 LONGEST. */
14f9c5c9
AS
6989 RU = 0;
6990 while (isdigit (str[k]))
6991 {
d2e4a39e 6992 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6993 k += 1;
6994 }
6995
d2e4a39e 6996 if (str[k] == 'm')
14f9c5c9
AS
6997 {
6998 if (R != NULL)
4c4b4cd2 6999 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7000 k += 1;
7001 }
7002 else if (R != NULL)
7003 *R = (LONGEST) RU;
7004
4c4b4cd2 7005 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7006 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7007 number representable as a LONGEST (although either would probably work
7008 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7009 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7010
7011 if (new_k != NULL)
7012 *new_k = k;
7013 return 1;
7014}
7015
4c4b4cd2
PH
7016/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7017 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7018 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7019
d2e4a39e 7020int
ebf56fd3 7021ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7022{
d2e4a39e 7023 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7024 int p;
7025
7026 p = 0;
7027 while (1)
7028 {
d2e4a39e 7029 switch (name[p])
4c4b4cd2
PH
7030 {
7031 case '\0':
7032 return 0;
7033 case 'S':
7034 {
7035 LONGEST W;
5b4ee69b 7036
4c4b4cd2
PH
7037 if (!ada_scan_number (name, p + 1, &W, &p))
7038 return 0;
7039 if (val == W)
7040 return 1;
7041 break;
7042 }
7043 case 'R':
7044 {
7045 LONGEST L, U;
5b4ee69b 7046
4c4b4cd2
PH
7047 if (!ada_scan_number (name, p + 1, &L, &p)
7048 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7049 return 0;
7050 if (val >= L && val <= U)
7051 return 1;
7052 break;
7053 }
7054 case 'O':
7055 return 1;
7056 default:
7057 return 0;
7058 }
7059 }
7060}
7061
0963b4bd 7062/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7063
7064/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7065 ARG_TYPE, extract and return the value of one of its (non-static)
7066 fields. FIELDNO says which field. Differs from value_primitive_field
7067 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7068
4c4b4cd2 7069static struct value *
d2e4a39e 7070ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7071 struct type *arg_type)
14f9c5c9 7072{
14f9c5c9
AS
7073 struct type *type;
7074
61ee279c 7075 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7076 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7077
4504bbde
TT
7078 /* Handle packed fields. It might be that the field is not packed
7079 relative to its containing structure, but the structure itself is
7080 packed; in this case we must take the bit-field path. */
7081 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0 || value_bitpos (arg1) != 0)
14f9c5c9
AS
7082 {
7083 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7084 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7085
0fd88904 7086 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7087 offset + bit_pos / 8,
7088 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7089 }
7090 else
7091 return value_primitive_field (arg1, offset, fieldno, arg_type);
7092}
7093
52ce6436
PH
7094/* Find field with name NAME in object of type TYPE. If found,
7095 set the following for each argument that is non-null:
7096 - *FIELD_TYPE_P to the field's type;
7097 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7098 an object of that type;
7099 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7100 - *BIT_SIZE_P to its size in bits if the field is packed, and
7101 0 otherwise;
7102 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7103 fields up to but not including the desired field, or by the total
7104 number of fields if not found. A NULL value of NAME never
7105 matches; the function just counts visible fields in this case.
7106
828d5846
XR
7107 Notice that we need to handle when a tagged record hierarchy
7108 has some components with the same name, like in this scenario:
7109
7110 type Top_T is tagged record
7111 N : Integer := 1;
7112 U : Integer := 974;
7113 A : Integer := 48;
7114 end record;
7115
7116 type Middle_T is new Top.Top_T with record
7117 N : Character := 'a';
7118 C : Integer := 3;
7119 end record;
7120
7121 type Bottom_T is new Middle.Middle_T with record
7122 N : Float := 4.0;
7123 C : Character := '5';
7124 X : Integer := 6;
7125 A : Character := 'J';
7126 end record;
7127
7128 Let's say we now have a variable declared and initialized as follow:
7129
7130 TC : Top_A := new Bottom_T;
7131
7132 And then we use this variable to call this function
7133
7134 procedure Assign (Obj: in out Top_T; TV : Integer);
7135
7136 as follow:
7137
7138 Assign (Top_T (B), 12);
7139
7140 Now, we're in the debugger, and we're inside that procedure
7141 then and we want to print the value of obj.c:
7142
7143 Usually, the tagged record or one of the parent type owns the
7144 component to print and there's no issue but in this particular
7145 case, what does it mean to ask for Obj.C? Since the actual
7146 type for object is type Bottom_T, it could mean two things: type
7147 component C from the Middle_T view, but also component C from
7148 Bottom_T. So in that "undefined" case, when the component is
7149 not found in the non-resolved type (which includes all the
7150 components of the parent type), then resolve it and see if we
7151 get better luck once expanded.
7152
7153 In the case of homonyms in the derived tagged type, we don't
7154 guaranty anything, and pick the one that's easiest for us
7155 to program.
7156
0963b4bd 7157 Returns 1 if found, 0 otherwise. */
52ce6436 7158
4c4b4cd2 7159static int
0d5cff50 7160find_struct_field (const char *name, struct type *type, int offset,
76a01679 7161 struct type **field_type_p,
52ce6436
PH
7162 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7163 int *index_p)
4c4b4cd2
PH
7164{
7165 int i;
828d5846 7166 int parent_offset = -1;
4c4b4cd2 7167
61ee279c 7168 type = ada_check_typedef (type);
76a01679 7169
52ce6436
PH
7170 if (field_type_p != NULL)
7171 *field_type_p = NULL;
7172 if (byte_offset_p != NULL)
d5d6fca5 7173 *byte_offset_p = 0;
52ce6436
PH
7174 if (bit_offset_p != NULL)
7175 *bit_offset_p = 0;
7176 if (bit_size_p != NULL)
7177 *bit_size_p = 0;
7178
7179 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7180 {
7181 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7182 int fld_offset = offset + bit_pos / 8;
0d5cff50 7183 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7184
4c4b4cd2
PH
7185 if (t_field_name == NULL)
7186 continue;
7187
828d5846
XR
7188 else if (ada_is_parent_field (type, i))
7189 {
7190 /* This is a field pointing us to the parent type of a tagged
7191 type. As hinted in this function's documentation, we give
7192 preference to fields in the current record first, so what
7193 we do here is just record the index of this field before
7194 we skip it. If it turns out we couldn't find our field
7195 in the current record, then we'll get back to it and search
7196 inside it whether the field might exist in the parent. */
7197
7198 parent_offset = i;
7199 continue;
7200 }
7201
52ce6436 7202 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7203 {
7204 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7205
52ce6436
PH
7206 if (field_type_p != NULL)
7207 *field_type_p = TYPE_FIELD_TYPE (type, i);
7208 if (byte_offset_p != NULL)
7209 *byte_offset_p = fld_offset;
7210 if (bit_offset_p != NULL)
7211 *bit_offset_p = bit_pos % 8;
7212 if (bit_size_p != NULL)
7213 *bit_size_p = bit_size;
76a01679
JB
7214 return 1;
7215 }
4c4b4cd2
PH
7216 else if (ada_is_wrapper_field (type, i))
7217 {
52ce6436
PH
7218 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7219 field_type_p, byte_offset_p, bit_offset_p,
7220 bit_size_p, index_p))
76a01679
JB
7221 return 1;
7222 }
4c4b4cd2
PH
7223 else if (ada_is_variant_part (type, i))
7224 {
52ce6436
PH
7225 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7226 fixed type?? */
4c4b4cd2 7227 int j;
52ce6436
PH
7228 struct type *field_type
7229 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7230
52ce6436 7231 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7232 {
76a01679
JB
7233 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7234 fld_offset
7235 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7236 field_type_p, byte_offset_p,
52ce6436 7237 bit_offset_p, bit_size_p, index_p))
76a01679 7238 return 1;
4c4b4cd2
PH
7239 }
7240 }
52ce6436
PH
7241 else if (index_p != NULL)
7242 *index_p += 1;
4c4b4cd2 7243 }
828d5846
XR
7244
7245 /* Field not found so far. If this is a tagged type which
7246 has a parent, try finding that field in the parent now. */
7247
7248 if (parent_offset != -1)
7249 {
7250 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7251 int fld_offset = offset + bit_pos / 8;
7252
7253 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7254 fld_offset, field_type_p, byte_offset_p,
7255 bit_offset_p, bit_size_p, index_p))
7256 return 1;
7257 }
7258
4c4b4cd2
PH
7259 return 0;
7260}
7261
0963b4bd 7262/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7263
52ce6436
PH
7264static int
7265num_visible_fields (struct type *type)
7266{
7267 int n;
5b4ee69b 7268
52ce6436
PH
7269 n = 0;
7270 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7271 return n;
7272}
14f9c5c9 7273
4c4b4cd2 7274/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7275 and search in it assuming it has (class) type TYPE.
7276 If found, return value, else return NULL.
7277
828d5846
XR
7278 Searches recursively through wrapper fields (e.g., '_parent').
7279
7280 In the case of homonyms in the tagged types, please refer to the
7281 long explanation in find_struct_field's function documentation. */
14f9c5c9 7282
4c4b4cd2 7283static struct value *
108d56a4 7284ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7285 struct type *type)
14f9c5c9
AS
7286{
7287 int i;
828d5846 7288 int parent_offset = -1;
14f9c5c9 7289
5b4ee69b 7290 type = ada_check_typedef (type);
52ce6436 7291 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7292 {
0d5cff50 7293 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7294
7295 if (t_field_name == NULL)
4c4b4cd2 7296 continue;
14f9c5c9 7297
828d5846
XR
7298 else if (ada_is_parent_field (type, i))
7299 {
7300 /* This is a field pointing us to the parent type of a tagged
7301 type. As hinted in this function's documentation, we give
7302 preference to fields in the current record first, so what
7303 we do here is just record the index of this field before
7304 we skip it. If it turns out we couldn't find our field
7305 in the current record, then we'll get back to it and search
7306 inside it whether the field might exist in the parent. */
7307
7308 parent_offset = i;
7309 continue;
7310 }
7311
14f9c5c9 7312 else if (field_name_match (t_field_name, name))
4c4b4cd2 7313 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7314
7315 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7316 {
0963b4bd 7317 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7318 ada_search_struct_field (name, arg,
7319 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7320 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7321
4c4b4cd2
PH
7322 if (v != NULL)
7323 return v;
7324 }
14f9c5c9
AS
7325
7326 else if (ada_is_variant_part (type, i))
4c4b4cd2 7327 {
0963b4bd 7328 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7329 int j;
5b4ee69b
MS
7330 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7331 i));
4c4b4cd2
PH
7332 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7333
52ce6436 7334 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7335 {
0963b4bd
MS
7336 struct value *v = ada_search_struct_field /* Force line
7337 break. */
06d5cf63
JB
7338 (name, arg,
7339 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7340 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7341
4c4b4cd2
PH
7342 if (v != NULL)
7343 return v;
7344 }
7345 }
14f9c5c9 7346 }
828d5846
XR
7347
7348 /* Field not found so far. If this is a tagged type which
7349 has a parent, try finding that field in the parent now. */
7350
7351 if (parent_offset != -1)
7352 {
7353 struct value *v = ada_search_struct_field (
7354 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7355 TYPE_FIELD_TYPE (type, parent_offset));
7356
7357 if (v != NULL)
7358 return v;
7359 }
7360
14f9c5c9
AS
7361 return NULL;
7362}
d2e4a39e 7363
52ce6436
PH
7364static struct value *ada_index_struct_field_1 (int *, struct value *,
7365 int, struct type *);
7366
7367
7368/* Return field #INDEX in ARG, where the index is that returned by
7369 * find_struct_field through its INDEX_P argument. Adjust the address
7370 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7371 * If found, return value, else return NULL. */
52ce6436
PH
7372
7373static struct value *
7374ada_index_struct_field (int index, struct value *arg, int offset,
7375 struct type *type)
7376{
7377 return ada_index_struct_field_1 (&index, arg, offset, type);
7378}
7379
7380
7381/* Auxiliary function for ada_index_struct_field. Like
7382 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7383 * *INDEX_P. */
52ce6436
PH
7384
7385static struct value *
7386ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7387 struct type *type)
7388{
7389 int i;
7390 type = ada_check_typedef (type);
7391
7392 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7393 {
7394 if (TYPE_FIELD_NAME (type, i) == NULL)
7395 continue;
7396 else if (ada_is_wrapper_field (type, i))
7397 {
0963b4bd 7398 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7399 ada_index_struct_field_1 (index_p, arg,
7400 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7401 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7402
52ce6436
PH
7403 if (v != NULL)
7404 return v;
7405 }
7406
7407 else if (ada_is_variant_part (type, i))
7408 {
7409 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7410 find_struct_field. */
52ce6436
PH
7411 error (_("Cannot assign this kind of variant record"));
7412 }
7413 else if (*index_p == 0)
7414 return ada_value_primitive_field (arg, offset, i, type);
7415 else
7416 *index_p -= 1;
7417 }
7418 return NULL;
7419}
7420
4c4b4cd2
PH
7421/* Given ARG, a value of type (pointer or reference to a)*
7422 structure/union, extract the component named NAME from the ultimate
7423 target structure/union and return it as a value with its
f5938064 7424 appropriate type.
14f9c5c9 7425
4c4b4cd2
PH
7426 The routine searches for NAME among all members of the structure itself
7427 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7428 (e.g., '_parent').
7429
03ee6b2e
PH
7430 If NO_ERR, then simply return NULL in case of error, rather than
7431 calling error. */
14f9c5c9 7432
d2e4a39e 7433struct value *
a121b7c1 7434ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7435{
4c4b4cd2 7436 struct type *t, *t1;
d2e4a39e 7437 struct value *v;
1f5d1570 7438 int check_tag;
14f9c5c9 7439
4c4b4cd2 7440 v = NULL;
df407dfe 7441 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7442 if (TYPE_CODE (t) == TYPE_CODE_REF)
7443 {
7444 t1 = TYPE_TARGET_TYPE (t);
7445 if (t1 == NULL)
03ee6b2e 7446 goto BadValue;
61ee279c 7447 t1 = ada_check_typedef (t1);
4c4b4cd2 7448 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7449 {
994b9211 7450 arg = coerce_ref (arg);
76a01679
JB
7451 t = t1;
7452 }
4c4b4cd2 7453 }
14f9c5c9 7454
4c4b4cd2
PH
7455 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7456 {
7457 t1 = TYPE_TARGET_TYPE (t);
7458 if (t1 == NULL)
03ee6b2e 7459 goto BadValue;
61ee279c 7460 t1 = ada_check_typedef (t1);
4c4b4cd2 7461 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7462 {
7463 arg = value_ind (arg);
7464 t = t1;
7465 }
4c4b4cd2 7466 else
76a01679 7467 break;
4c4b4cd2 7468 }
14f9c5c9 7469
4c4b4cd2 7470 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7471 goto BadValue;
14f9c5c9 7472
4c4b4cd2
PH
7473 if (t1 == t)
7474 v = ada_search_struct_field (name, arg, 0, t);
7475 else
7476 {
7477 int bit_offset, bit_size, byte_offset;
7478 struct type *field_type;
7479 CORE_ADDR address;
7480
76a01679 7481 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7482 address = value_address (ada_value_ind (arg));
4c4b4cd2 7483 else
b50d69b5 7484 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7485
828d5846
XR
7486 /* Check to see if this is a tagged type. We also need to handle
7487 the case where the type is a reference to a tagged type, but
7488 we have to be careful to exclude pointers to tagged types.
7489 The latter should be shown as usual (as a pointer), whereas
7490 a reference should mostly be transparent to the user. */
7491
7492 if (ada_is_tagged_type (t1, 0)
7493 || (TYPE_CODE (t1) == TYPE_CODE_REF
7494 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7495 {
7496 /* We first try to find the searched field in the current type.
7497 If not found then let's look in the fixed type. */
7498
7499 if (!find_struct_field (name, t1, 0,
7500 &field_type, &byte_offset, &bit_offset,
7501 &bit_size, NULL))
1f5d1570
JG
7502 check_tag = 1;
7503 else
7504 check_tag = 0;
828d5846
XR
7505 }
7506 else
1f5d1570
JG
7507 check_tag = 0;
7508
7509 /* Convert to fixed type in all cases, so that we have proper
7510 offsets to each field in unconstrained record types. */
7511 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7512 address, NULL, check_tag);
828d5846 7513
76a01679
JB
7514 if (find_struct_field (name, t1, 0,
7515 &field_type, &byte_offset, &bit_offset,
52ce6436 7516 &bit_size, NULL))
76a01679
JB
7517 {
7518 if (bit_size != 0)
7519 {
714e53ab
PH
7520 if (TYPE_CODE (t) == TYPE_CODE_REF)
7521 arg = ada_coerce_ref (arg);
7522 else
7523 arg = ada_value_ind (arg);
76a01679
JB
7524 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7525 bit_offset, bit_size,
7526 field_type);
7527 }
7528 else
f5938064 7529 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7530 }
7531 }
7532
03ee6b2e
PH
7533 if (v != NULL || no_err)
7534 return v;
7535 else
323e0a4a 7536 error (_("There is no member named %s."), name);
14f9c5c9 7537
03ee6b2e
PH
7538 BadValue:
7539 if (no_err)
7540 return NULL;
7541 else
0963b4bd
MS
7542 error (_("Attempt to extract a component of "
7543 "a value that is not a record."));
14f9c5c9
AS
7544}
7545
3b4de39c 7546/* Return a string representation of type TYPE. */
99bbb428 7547
3b4de39c 7548static std::string
99bbb428
PA
7549type_as_string (struct type *type)
7550{
d7e74731 7551 string_file tmp_stream;
99bbb428 7552
d7e74731 7553 type_print (type, "", &tmp_stream, -1);
99bbb428 7554
d7e74731 7555 return std::move (tmp_stream.string ());
99bbb428
PA
7556}
7557
14f9c5c9 7558/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7559 If DISPP is non-null, add its byte displacement from the beginning of a
7560 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7561 work for packed fields).
7562
7563 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7564 followed by "___".
14f9c5c9 7565
0963b4bd 7566 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7567 be a (pointer or reference)+ to a struct or union, and the
7568 ultimate target type will be searched.
14f9c5c9
AS
7569
7570 Looks recursively into variant clauses and parent types.
7571
828d5846
XR
7572 In the case of homonyms in the tagged types, please refer to the
7573 long explanation in find_struct_field's function documentation.
7574
4c4b4cd2
PH
7575 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7576 TYPE is not a type of the right kind. */
14f9c5c9 7577
4c4b4cd2 7578static struct type *
a121b7c1 7579ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7580 int noerr)
14f9c5c9
AS
7581{
7582 int i;
828d5846 7583 int parent_offset = -1;
14f9c5c9
AS
7584
7585 if (name == NULL)
7586 goto BadName;
7587
76a01679 7588 if (refok && type != NULL)
4c4b4cd2
PH
7589 while (1)
7590 {
61ee279c 7591 type = ada_check_typedef (type);
76a01679
JB
7592 if (TYPE_CODE (type) != TYPE_CODE_PTR
7593 && TYPE_CODE (type) != TYPE_CODE_REF)
7594 break;
7595 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7596 }
14f9c5c9 7597
76a01679 7598 if (type == NULL
1265e4aa
JB
7599 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7600 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7601 {
4c4b4cd2 7602 if (noerr)
76a01679 7603 return NULL;
99bbb428 7604
3b4de39c
PA
7605 error (_("Type %s is not a structure or union type"),
7606 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7607 }
7608
7609 type = to_static_fixed_type (type);
7610
7611 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7612 {
0d5cff50 7613 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7614 struct type *t;
d2e4a39e 7615
14f9c5c9 7616 if (t_field_name == NULL)
4c4b4cd2 7617 continue;
14f9c5c9 7618
828d5846
XR
7619 else if (ada_is_parent_field (type, i))
7620 {
7621 /* This is a field pointing us to the parent type of a tagged
7622 type. As hinted in this function's documentation, we give
7623 preference to fields in the current record first, so what
7624 we do here is just record the index of this field before
7625 we skip it. If it turns out we couldn't find our field
7626 in the current record, then we'll get back to it and search
7627 inside it whether the field might exist in the parent. */
7628
7629 parent_offset = i;
7630 continue;
7631 }
7632
14f9c5c9 7633 else if (field_name_match (t_field_name, name))
988f6b3d 7634 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7635
7636 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7637 {
4c4b4cd2 7638 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7639 0, 1);
4c4b4cd2 7640 if (t != NULL)
988f6b3d 7641 return t;
4c4b4cd2 7642 }
14f9c5c9
AS
7643
7644 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7645 {
7646 int j;
5b4ee69b
MS
7647 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7648 i));
4c4b4cd2
PH
7649
7650 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7651 {
b1f33ddd
JB
7652 /* FIXME pnh 2008/01/26: We check for a field that is
7653 NOT wrapped in a struct, since the compiler sometimes
7654 generates these for unchecked variant types. Revisit
0963b4bd 7655 if the compiler changes this practice. */
0d5cff50 7656 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7657
b1f33ddd
JB
7658 if (v_field_name != NULL
7659 && field_name_match (v_field_name, name))
460efde1 7660 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7661 else
0963b4bd
MS
7662 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7663 j),
988f6b3d 7664 name, 0, 1);
b1f33ddd 7665
4c4b4cd2 7666 if (t != NULL)
988f6b3d 7667 return t;
4c4b4cd2
PH
7668 }
7669 }
14f9c5c9
AS
7670
7671 }
7672
828d5846
XR
7673 /* Field not found so far. If this is a tagged type which
7674 has a parent, try finding that field in the parent now. */
7675
7676 if (parent_offset != -1)
7677 {
7678 struct type *t;
7679
7680 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7681 name, 0, 1);
7682 if (t != NULL)
7683 return t;
7684 }
7685
14f9c5c9 7686BadName:
d2e4a39e 7687 if (!noerr)
14f9c5c9 7688 {
2b2798cc 7689 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7690
7691 error (_("Type %s has no component named %s"),
3b4de39c 7692 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7693 }
7694
7695 return NULL;
7696}
7697
b1f33ddd
JB
7698/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7699 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7700 represents an unchecked union (that is, the variant part of a
0963b4bd 7701 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7702
7703static int
7704is_unchecked_variant (struct type *var_type, struct type *outer_type)
7705{
a121b7c1 7706 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7707
988f6b3d 7708 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7709}
7710
7711
14f9c5c9
AS
7712/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7713 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7714 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7715 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7716
d2e4a39e 7717int
ebf56fd3 7718ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7719 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7720{
7721 int others_clause;
7722 int i;
a121b7c1 7723 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7724 struct value *outer;
7725 struct value *discrim;
14f9c5c9
AS
7726 LONGEST discrim_val;
7727
012370f6
TT
7728 /* Using plain value_from_contents_and_address here causes problems
7729 because we will end up trying to resolve a type that is currently
7730 being constructed. */
7731 outer = value_from_contents_and_address_unresolved (outer_type,
7732 outer_valaddr, 0);
0c281816
JB
7733 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7734 if (discrim == NULL)
14f9c5c9 7735 return -1;
0c281816 7736 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7737
7738 others_clause = -1;
7739 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7740 {
7741 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7742 others_clause = i;
14f9c5c9 7743 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7744 return i;
14f9c5c9
AS
7745 }
7746
7747 return others_clause;
7748}
d2e4a39e 7749\f
14f9c5c9
AS
7750
7751
4c4b4cd2 7752 /* Dynamic-Sized Records */
14f9c5c9
AS
7753
7754/* Strategy: The type ostensibly attached to a value with dynamic size
7755 (i.e., a size that is not statically recorded in the debugging
7756 data) does not accurately reflect the size or layout of the value.
7757 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7758 conventional types that are constructed on the fly. */
14f9c5c9
AS
7759
7760/* There is a subtle and tricky problem here. In general, we cannot
7761 determine the size of dynamic records without its data. However,
7762 the 'struct value' data structure, which GDB uses to represent
7763 quantities in the inferior process (the target), requires the size
7764 of the type at the time of its allocation in order to reserve space
7765 for GDB's internal copy of the data. That's why the
7766 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7767 rather than struct value*s.
14f9c5c9
AS
7768
7769 However, GDB's internal history variables ($1, $2, etc.) are
7770 struct value*s containing internal copies of the data that are not, in
7771 general, the same as the data at their corresponding addresses in
7772 the target. Fortunately, the types we give to these values are all
7773 conventional, fixed-size types (as per the strategy described
7774 above), so that we don't usually have to perform the
7775 'to_fixed_xxx_type' conversions to look at their values.
7776 Unfortunately, there is one exception: if one of the internal
7777 history variables is an array whose elements are unconstrained
7778 records, then we will need to create distinct fixed types for each
7779 element selected. */
7780
7781/* The upshot of all of this is that many routines take a (type, host
7782 address, target address) triple as arguments to represent a value.
7783 The host address, if non-null, is supposed to contain an internal
7784 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7785 target at the target address. */
14f9c5c9
AS
7786
7787/* Assuming that VAL0 represents a pointer value, the result of
7788 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7789 dynamic-sized types. */
14f9c5c9 7790
d2e4a39e
AS
7791struct value *
7792ada_value_ind (struct value *val0)
14f9c5c9 7793{
c48db5ca 7794 struct value *val = value_ind (val0);
5b4ee69b 7795
b50d69b5
JG
7796 if (ada_is_tagged_type (value_type (val), 0))
7797 val = ada_tag_value_at_base_address (val);
7798
4c4b4cd2 7799 return ada_to_fixed_value (val);
14f9c5c9
AS
7800}
7801
7802/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7803 qualifiers on VAL0. */
7804
d2e4a39e
AS
7805static struct value *
7806ada_coerce_ref (struct value *val0)
7807{
df407dfe 7808 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7809 {
7810 struct value *val = val0;
5b4ee69b 7811
994b9211 7812 val = coerce_ref (val);
b50d69b5
JG
7813
7814 if (ada_is_tagged_type (value_type (val), 0))
7815 val = ada_tag_value_at_base_address (val);
7816
4c4b4cd2 7817 return ada_to_fixed_value (val);
d2e4a39e
AS
7818 }
7819 else
14f9c5c9
AS
7820 return val0;
7821}
7822
7823/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7824 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7825
7826static unsigned int
ebf56fd3 7827align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7828{
7829 return (off + alignment - 1) & ~(alignment - 1);
7830}
7831
4c4b4cd2 7832/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7833
7834static unsigned int
ebf56fd3 7835field_alignment (struct type *type, int f)
14f9c5c9 7836{
d2e4a39e 7837 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7838 int len;
14f9c5c9
AS
7839 int align_offset;
7840
64a1bf19
JB
7841 /* The field name should never be null, unless the debugging information
7842 is somehow malformed. In this case, we assume the field does not
7843 require any alignment. */
7844 if (name == NULL)
7845 return 1;
7846
7847 len = strlen (name);
7848
4c4b4cd2
PH
7849 if (!isdigit (name[len - 1]))
7850 return 1;
14f9c5c9 7851
d2e4a39e 7852 if (isdigit (name[len - 2]))
14f9c5c9
AS
7853 align_offset = len - 2;
7854 else
7855 align_offset = len - 1;
7856
61012eef 7857 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7858 return TARGET_CHAR_BIT;
7859
4c4b4cd2
PH
7860 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7861}
7862
852dff6c 7863/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7864
852dff6c
JB
7865static struct symbol *
7866ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7867{
7868 struct symbol *sym;
7869
7870 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7871 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7872 return sym;
7873
4186eb54
KS
7874 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7875 return sym;
14f9c5c9
AS
7876}
7877
dddfab26
UW
7878/* Find a type named NAME. Ignores ambiguity. This routine will look
7879 solely for types defined by debug info, it will not search the GDB
7880 primitive types. */
4c4b4cd2 7881
852dff6c 7882static struct type *
ebf56fd3 7883ada_find_any_type (const char *name)
14f9c5c9 7884{
852dff6c 7885 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7886
14f9c5c9 7887 if (sym != NULL)
dddfab26 7888 return SYMBOL_TYPE (sym);
14f9c5c9 7889
dddfab26 7890 return NULL;
14f9c5c9
AS
7891}
7892
739593e0
JB
7893/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7894 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7895 symbol, in which case it is returned. Otherwise, this looks for
7896 symbols whose name is that of NAME_SYM suffixed with "___XR".
7897 Return symbol if found, and NULL otherwise. */
4c4b4cd2 7898
c0e70c62
TT
7899static bool
7900ada_is_renaming_symbol (struct symbol *name_sym)
aeb5907d 7901{
739593e0 7902 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
c0e70c62 7903 return strstr (name, "___XR") != NULL;
4c4b4cd2
PH
7904}
7905
14f9c5c9 7906/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7907 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7908 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7909 otherwise return 0. */
7910
14f9c5c9 7911int
d2e4a39e 7912ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7913{
7914 if (type1 == NULL)
7915 return 1;
7916 else if (type0 == NULL)
7917 return 0;
7918 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7919 return 1;
7920 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7921 return 0;
4c4b4cd2
PH
7922 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7923 return 1;
ad82864c 7924 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7925 return 1;
4c4b4cd2
PH
7926 else if (ada_is_array_descriptor_type (type0)
7927 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7928 return 1;
aeb5907d
JB
7929 else
7930 {
a737d952
TT
7931 const char *type0_name = TYPE_NAME (type0);
7932 const char *type1_name = TYPE_NAME (type1);
aeb5907d
JB
7933
7934 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7935 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7936 return 1;
7937 }
14f9c5c9
AS
7938 return 0;
7939}
7940
e86ca25f
TT
7941/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7942 null. */
4c4b4cd2 7943
0d5cff50 7944const char *
d2e4a39e 7945ada_type_name (struct type *type)
14f9c5c9 7946{
d2e4a39e 7947 if (type == NULL)
14f9c5c9 7948 return NULL;
e86ca25f 7949 return TYPE_NAME (type);
14f9c5c9
AS
7950}
7951
b4ba55a1
JB
7952/* Search the list of "descriptive" types associated to TYPE for a type
7953 whose name is NAME. */
7954
7955static struct type *
7956find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7957{
931e5bc3 7958 struct type *result, *tmp;
b4ba55a1 7959
c6044dd1
JB
7960 if (ada_ignore_descriptive_types_p)
7961 return NULL;
7962
b4ba55a1
JB
7963 /* If there no descriptive-type info, then there is no parallel type
7964 to be found. */
7965 if (!HAVE_GNAT_AUX_INFO (type))
7966 return NULL;
7967
7968 result = TYPE_DESCRIPTIVE_TYPE (type);
7969 while (result != NULL)
7970 {
0d5cff50 7971 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7972
7973 if (result_name == NULL)
7974 {
7975 warning (_("unexpected null name on descriptive type"));
7976 return NULL;
7977 }
7978
7979 /* If the names match, stop. */
7980 if (strcmp (result_name, name) == 0)
7981 break;
7982
7983 /* Otherwise, look at the next item on the list, if any. */
7984 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
7985 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7986 else
7987 tmp = NULL;
7988
7989 /* If not found either, try after having resolved the typedef. */
7990 if (tmp != NULL)
7991 result = tmp;
b4ba55a1 7992 else
931e5bc3 7993 {
f168693b 7994 result = check_typedef (result);
931e5bc3
JG
7995 if (HAVE_GNAT_AUX_INFO (result))
7996 result = TYPE_DESCRIPTIVE_TYPE (result);
7997 else
7998 result = NULL;
7999 }
b4ba55a1
JB
8000 }
8001
8002 /* If we didn't find a match, see whether this is a packed array. With
8003 older compilers, the descriptive type information is either absent or
8004 irrelevant when it comes to packed arrays so the above lookup fails.
8005 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8006 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8007 return ada_find_any_type (name);
8008
8009 return result;
8010}
8011
8012/* Find a parallel type to TYPE with the specified NAME, using the
8013 descriptive type taken from the debugging information, if available,
8014 and otherwise using the (slower) name-based method. */
8015
8016static struct type *
8017ada_find_parallel_type_with_name (struct type *type, const char *name)
8018{
8019 struct type *result = NULL;
8020
8021 if (HAVE_GNAT_AUX_INFO (type))
8022 result = find_parallel_type_by_descriptive_type (type, name);
8023 else
8024 result = ada_find_any_type (name);
8025
8026 return result;
8027}
8028
8029/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8030 SUFFIX to the name of TYPE. */
14f9c5c9 8031
d2e4a39e 8032struct type *
ebf56fd3 8033ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8034{
0d5cff50 8035 char *name;
fe978cb0 8036 const char *type_name = ada_type_name (type);
14f9c5c9 8037 int len;
d2e4a39e 8038
fe978cb0 8039 if (type_name == NULL)
14f9c5c9
AS
8040 return NULL;
8041
fe978cb0 8042 len = strlen (type_name);
14f9c5c9 8043
b4ba55a1 8044 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8045
fe978cb0 8046 strcpy (name, type_name);
14f9c5c9
AS
8047 strcpy (name + len, suffix);
8048
b4ba55a1 8049 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8050}
8051
14f9c5c9 8052/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8053 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8054
d2e4a39e
AS
8055static struct type *
8056dynamic_template_type (struct type *type)
14f9c5c9 8057{
61ee279c 8058 type = ada_check_typedef (type);
14f9c5c9
AS
8059
8060 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8061 || ada_type_name (type) == NULL)
14f9c5c9 8062 return NULL;
d2e4a39e 8063 else
14f9c5c9
AS
8064 {
8065 int len = strlen (ada_type_name (type));
5b4ee69b 8066
4c4b4cd2
PH
8067 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8068 return type;
14f9c5c9 8069 else
4c4b4cd2 8070 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8071 }
8072}
8073
8074/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8075 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8076
d2e4a39e
AS
8077static int
8078is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8079{
8080 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8081
d2e4a39e 8082 return name != NULL
14f9c5c9
AS
8083 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8084 && strstr (name, "___XVL") != NULL;
8085}
8086
4c4b4cd2
PH
8087/* The index of the variant field of TYPE, or -1 if TYPE does not
8088 represent a variant record type. */
14f9c5c9 8089
d2e4a39e 8090static int
4c4b4cd2 8091variant_field_index (struct type *type)
14f9c5c9
AS
8092{
8093 int f;
8094
4c4b4cd2
PH
8095 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8096 return -1;
8097
8098 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8099 {
8100 if (ada_is_variant_part (type, f))
8101 return f;
8102 }
8103 return -1;
14f9c5c9
AS
8104}
8105
4c4b4cd2
PH
8106/* A record type with no fields. */
8107
d2e4a39e 8108static struct type *
fe978cb0 8109empty_record (struct type *templ)
14f9c5c9 8110{
fe978cb0 8111 struct type *type = alloc_type_copy (templ);
5b4ee69b 8112
14f9c5c9
AS
8113 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8114 TYPE_NFIELDS (type) = 0;
8115 TYPE_FIELDS (type) = NULL;
8ecb59f8 8116 INIT_NONE_SPECIFIC (type);
14f9c5c9 8117 TYPE_NAME (type) = "<empty>";
14f9c5c9
AS
8118 TYPE_LENGTH (type) = 0;
8119 return type;
8120}
8121
8122/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8123 the value of type TYPE at VALADDR or ADDRESS (see comments at
8124 the beginning of this section) VAL according to GNAT conventions.
8125 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8126 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8127 an outer-level type (i.e., as opposed to a branch of a variant.) A
8128 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8129 of the variant.
14f9c5c9 8130
4c4b4cd2
PH
8131 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8132 length are not statically known are discarded. As a consequence,
8133 VALADDR, ADDRESS and DVAL0 are ignored.
8134
8135 NOTE: Limitations: For now, we assume that dynamic fields and
8136 variants occupy whole numbers of bytes. However, they need not be
8137 byte-aligned. */
8138
8139struct type *
10a2c479 8140ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8141 const gdb_byte *valaddr,
4c4b4cd2
PH
8142 CORE_ADDR address, struct value *dval0,
8143 int keep_dynamic_fields)
14f9c5c9 8144{
d2e4a39e
AS
8145 struct value *mark = value_mark ();
8146 struct value *dval;
8147 struct type *rtype;
14f9c5c9 8148 int nfields, bit_len;
4c4b4cd2 8149 int variant_field;
14f9c5c9 8150 long off;
d94e4f4f 8151 int fld_bit_len;
14f9c5c9
AS
8152 int f;
8153
4c4b4cd2
PH
8154 /* Compute the number of fields in this record type that are going
8155 to be processed: unless keep_dynamic_fields, this includes only
8156 fields whose position and length are static will be processed. */
8157 if (keep_dynamic_fields)
8158 nfields = TYPE_NFIELDS (type);
8159 else
8160 {
8161 nfields = 0;
76a01679 8162 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8163 && !ada_is_variant_part (type, nfields)
8164 && !is_dynamic_field (type, nfields))
8165 nfields++;
8166 }
8167
e9bb382b 8168 rtype = alloc_type_copy (type);
14f9c5c9 8169 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8ecb59f8 8170 INIT_NONE_SPECIFIC (rtype);
14f9c5c9 8171 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8172 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8173 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8174 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8175 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8176 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8177
d2e4a39e
AS
8178 off = 0;
8179 bit_len = 0;
4c4b4cd2
PH
8180 variant_field = -1;
8181
14f9c5c9
AS
8182 for (f = 0; f < nfields; f += 1)
8183 {
6c038f32
PH
8184 off = align_value (off, field_alignment (type, f))
8185 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8186 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8187 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8188
d2e4a39e 8189 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8190 {
8191 variant_field = f;
d94e4f4f 8192 fld_bit_len = 0;
4c4b4cd2 8193 }
14f9c5c9 8194 else if (is_dynamic_field (type, f))
4c4b4cd2 8195 {
284614f0
JB
8196 const gdb_byte *field_valaddr = valaddr;
8197 CORE_ADDR field_address = address;
8198 struct type *field_type =
8199 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8200
4c4b4cd2 8201 if (dval0 == NULL)
b5304971
JG
8202 {
8203 /* rtype's length is computed based on the run-time
8204 value of discriminants. If the discriminants are not
8205 initialized, the type size may be completely bogus and
0963b4bd 8206 GDB may fail to allocate a value for it. So check the
b5304971 8207 size first before creating the value. */
c1b5a1a6 8208 ada_ensure_varsize_limit (rtype);
012370f6
TT
8209 /* Using plain value_from_contents_and_address here
8210 causes problems because we will end up trying to
8211 resolve a type that is currently being
8212 constructed. */
8213 dval = value_from_contents_and_address_unresolved (rtype,
8214 valaddr,
8215 address);
9f1f738a 8216 rtype = value_type (dval);
b5304971 8217 }
4c4b4cd2
PH
8218 else
8219 dval = dval0;
8220
284614f0
JB
8221 /* If the type referenced by this field is an aligner type, we need
8222 to unwrap that aligner type, because its size might not be set.
8223 Keeping the aligner type would cause us to compute the wrong
8224 size for this field, impacting the offset of the all the fields
8225 that follow this one. */
8226 if (ada_is_aligner_type (field_type))
8227 {
8228 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8229
8230 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8231 field_address = cond_offset_target (field_address, field_offset);
8232 field_type = ada_aligned_type (field_type);
8233 }
8234
8235 field_valaddr = cond_offset_host (field_valaddr,
8236 off / TARGET_CHAR_BIT);
8237 field_address = cond_offset_target (field_address,
8238 off / TARGET_CHAR_BIT);
8239
8240 /* Get the fixed type of the field. Note that, in this case,
8241 we do not want to get the real type out of the tag: if
8242 the current field is the parent part of a tagged record,
8243 we will get the tag of the object. Clearly wrong: the real
8244 type of the parent is not the real type of the child. We
8245 would end up in an infinite loop. */
8246 field_type = ada_get_base_type (field_type);
8247 field_type = ada_to_fixed_type (field_type, field_valaddr,
8248 field_address, dval, 0);
27f2a97b
JB
8249 /* If the field size is already larger than the maximum
8250 object size, then the record itself will necessarily
8251 be larger than the maximum object size. We need to make
8252 this check now, because the size might be so ridiculously
8253 large (due to an uninitialized variable in the inferior)
8254 that it would cause an overflow when adding it to the
8255 record size. */
c1b5a1a6 8256 ada_ensure_varsize_limit (field_type);
284614f0
JB
8257
8258 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8259 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8260 /* The multiplication can potentially overflow. But because
8261 the field length has been size-checked just above, and
8262 assuming that the maximum size is a reasonable value,
8263 an overflow should not happen in practice. So rather than
8264 adding overflow recovery code to this already complex code,
8265 we just assume that it's not going to happen. */
d94e4f4f 8266 fld_bit_len =
4c4b4cd2
PH
8267 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8268 }
14f9c5c9 8269 else
4c4b4cd2 8270 {
5ded5331
JB
8271 /* Note: If this field's type is a typedef, it is important
8272 to preserve the typedef layer.
8273
8274 Otherwise, we might be transforming a typedef to a fat
8275 pointer (encoding a pointer to an unconstrained array),
8276 into a basic fat pointer (encoding an unconstrained
8277 array). As both types are implemented using the same
8278 structure, the typedef is the only clue which allows us
8279 to distinguish between the two options. Stripping it
8280 would prevent us from printing this field appropriately. */
8281 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8282 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8283 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8284 fld_bit_len =
4c4b4cd2
PH
8285 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8286 else
5ded5331
JB
8287 {
8288 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8289
8290 /* We need to be careful of typedefs when computing
8291 the length of our field. If this is a typedef,
8292 get the length of the target type, not the length
8293 of the typedef. */
8294 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8295 field_type = ada_typedef_target_type (field_type);
8296
8297 fld_bit_len =
8298 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8299 }
4c4b4cd2 8300 }
14f9c5c9 8301 if (off + fld_bit_len > bit_len)
4c4b4cd2 8302 bit_len = off + fld_bit_len;
d94e4f4f 8303 off += fld_bit_len;
4c4b4cd2
PH
8304 TYPE_LENGTH (rtype) =
8305 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8306 }
4c4b4cd2
PH
8307
8308 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8309 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8310 the record. This can happen in the presence of representation
8311 clauses. */
8312 if (variant_field >= 0)
8313 {
8314 struct type *branch_type;
8315
8316 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8317
8318 if (dval0 == NULL)
9f1f738a 8319 {
012370f6
TT
8320 /* Using plain value_from_contents_and_address here causes
8321 problems because we will end up trying to resolve a type
8322 that is currently being constructed. */
8323 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8324 address);
9f1f738a
SA
8325 rtype = value_type (dval);
8326 }
4c4b4cd2
PH
8327 else
8328 dval = dval0;
8329
8330 branch_type =
8331 to_fixed_variant_branch_type
8332 (TYPE_FIELD_TYPE (type, variant_field),
8333 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8334 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8335 if (branch_type == NULL)
8336 {
8337 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8338 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8339 TYPE_NFIELDS (rtype) -= 1;
8340 }
8341 else
8342 {
8343 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8344 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8345 fld_bit_len =
8346 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8347 TARGET_CHAR_BIT;
8348 if (off + fld_bit_len > bit_len)
8349 bit_len = off + fld_bit_len;
8350 TYPE_LENGTH (rtype) =
8351 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8352 }
8353 }
8354
714e53ab
PH
8355 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8356 should contain the alignment of that record, which should be a strictly
8357 positive value. If null or negative, then something is wrong, most
8358 probably in the debug info. In that case, we don't round up the size
0963b4bd 8359 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8360 the current RTYPE length might be good enough for our purposes. */
8361 if (TYPE_LENGTH (type) <= 0)
8362 {
323e0a4a 8363 if (TYPE_NAME (rtype))
cc1defb1
KS
8364 warning (_("Invalid type size for `%s' detected: %s."),
8365 TYPE_NAME (rtype), pulongest (TYPE_LENGTH (type)));
323e0a4a 8366 else
cc1defb1
KS
8367 warning (_("Invalid type size for <unnamed> detected: %s."),
8368 pulongest (TYPE_LENGTH (type)));
714e53ab
PH
8369 }
8370 else
8371 {
8372 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8373 TYPE_LENGTH (type));
8374 }
14f9c5c9
AS
8375
8376 value_free_to_mark (mark);
d2e4a39e 8377 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8378 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8379 return rtype;
8380}
8381
4c4b4cd2
PH
8382/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8383 of 1. */
14f9c5c9 8384
d2e4a39e 8385static struct type *
fc1a4b47 8386template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8387 CORE_ADDR address, struct value *dval0)
8388{
8389 return ada_template_to_fixed_record_type_1 (type, valaddr,
8390 address, dval0, 1);
8391}
8392
8393/* An ordinary record type in which ___XVL-convention fields and
8394 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8395 static approximations, containing all possible fields. Uses
8396 no runtime values. Useless for use in values, but that's OK,
8397 since the results are used only for type determinations. Works on both
8398 structs and unions. Representation note: to save space, we memorize
8399 the result of this function in the TYPE_TARGET_TYPE of the
8400 template type. */
8401
8402static struct type *
8403template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8404{
8405 struct type *type;
8406 int nfields;
8407 int f;
8408
9e195661
PMR
8409 /* No need no do anything if the input type is already fixed. */
8410 if (TYPE_FIXED_INSTANCE (type0))
8411 return type0;
8412
8413 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8414 if (TYPE_TARGET_TYPE (type0) != NULL)
8415 return TYPE_TARGET_TYPE (type0);
8416
9e195661 8417 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8418 type = type0;
9e195661
PMR
8419 nfields = TYPE_NFIELDS (type0);
8420
8421 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8422 recompute all over next time. */
8423 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8424
8425 for (f = 0; f < nfields; f += 1)
8426 {
460efde1 8427 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8428 struct type *new_type;
14f9c5c9 8429
4c4b4cd2 8430 if (is_dynamic_field (type0, f))
460efde1
JB
8431 {
8432 field_type = ada_check_typedef (field_type);
8433 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8434 }
14f9c5c9 8435 else
f192137b 8436 new_type = static_unwrap_type (field_type);
9e195661
PMR
8437
8438 if (new_type != field_type)
8439 {
8440 /* Clone TYPE0 only the first time we get a new field type. */
8441 if (type == type0)
8442 {
8443 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8444 TYPE_CODE (type) = TYPE_CODE (type0);
8ecb59f8 8445 INIT_NONE_SPECIFIC (type);
9e195661
PMR
8446 TYPE_NFIELDS (type) = nfields;
8447 TYPE_FIELDS (type) = (struct field *)
8448 TYPE_ALLOC (type, nfields * sizeof (struct field));
8449 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8450 sizeof (struct field) * nfields);
8451 TYPE_NAME (type) = ada_type_name (type0);
9e195661
PMR
8452 TYPE_FIXED_INSTANCE (type) = 1;
8453 TYPE_LENGTH (type) = 0;
8454 }
8455 TYPE_FIELD_TYPE (type, f) = new_type;
8456 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8457 }
14f9c5c9 8458 }
9e195661 8459
14f9c5c9
AS
8460 return type;
8461}
8462
4c4b4cd2 8463/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8464 whose address in memory is ADDRESS, returns a revision of TYPE,
8465 which should be a non-dynamic-sized record, in which the variant
8466 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8467 for discriminant values in DVAL0, which can be NULL if the record
8468 contains the necessary discriminant values. */
8469
d2e4a39e 8470static struct type *
fc1a4b47 8471to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8472 CORE_ADDR address, struct value *dval0)
14f9c5c9 8473{
d2e4a39e 8474 struct value *mark = value_mark ();
4c4b4cd2 8475 struct value *dval;
d2e4a39e 8476 struct type *rtype;
14f9c5c9
AS
8477 struct type *branch_type;
8478 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8479 int variant_field = variant_field_index (type);
14f9c5c9 8480
4c4b4cd2 8481 if (variant_field == -1)
14f9c5c9
AS
8482 return type;
8483
4c4b4cd2 8484 if (dval0 == NULL)
9f1f738a
SA
8485 {
8486 dval = value_from_contents_and_address (type, valaddr, address);
8487 type = value_type (dval);
8488 }
4c4b4cd2
PH
8489 else
8490 dval = dval0;
8491
e9bb382b 8492 rtype = alloc_type_copy (type);
14f9c5c9 8493 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8ecb59f8 8494 INIT_NONE_SPECIFIC (rtype);
4c4b4cd2 8495 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8496 TYPE_FIELDS (rtype) =
8497 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8498 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8499 sizeof (struct field) * nfields);
14f9c5c9 8500 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8501 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8502 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8503
4c4b4cd2
PH
8504 branch_type = to_fixed_variant_branch_type
8505 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8506 cond_offset_host (valaddr,
4c4b4cd2
PH
8507 TYPE_FIELD_BITPOS (type, variant_field)
8508 / TARGET_CHAR_BIT),
d2e4a39e 8509 cond_offset_target (address,
4c4b4cd2
PH
8510 TYPE_FIELD_BITPOS (type, variant_field)
8511 / TARGET_CHAR_BIT), dval);
d2e4a39e 8512 if (branch_type == NULL)
14f9c5c9 8513 {
4c4b4cd2 8514 int f;
5b4ee69b 8515
4c4b4cd2
PH
8516 for (f = variant_field + 1; f < nfields; f += 1)
8517 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8518 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8519 }
8520 else
8521 {
4c4b4cd2
PH
8522 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8523 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8524 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8525 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8526 }
4c4b4cd2 8527 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8528
4c4b4cd2 8529 value_free_to_mark (mark);
14f9c5c9
AS
8530 return rtype;
8531}
8532
8533/* An ordinary record type (with fixed-length fields) that describes
8534 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8535 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8536 should be in DVAL, a record value; it may be NULL if the object
8537 at ADDR itself contains any necessary discriminant values.
8538 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8539 values from the record are needed. Except in the case that DVAL,
8540 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8541 unchecked) is replaced by a particular branch of the variant.
8542
8543 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8544 is questionable and may be removed. It can arise during the
8545 processing of an unconstrained-array-of-record type where all the
8546 variant branches have exactly the same size. This is because in
8547 such cases, the compiler does not bother to use the XVS convention
8548 when encoding the record. I am currently dubious of this
8549 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8550
d2e4a39e 8551static struct type *
fc1a4b47 8552to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8553 CORE_ADDR address, struct value *dval)
14f9c5c9 8554{
d2e4a39e 8555 struct type *templ_type;
14f9c5c9 8556
876cecd0 8557 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8558 return type0;
8559
d2e4a39e 8560 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8561
8562 if (templ_type != NULL)
8563 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8564 else if (variant_field_index (type0) >= 0)
8565 {
8566 if (dval == NULL && valaddr == NULL && address == 0)
8567 return type0;
8568 return to_record_with_fixed_variant_part (type0, valaddr, address,
8569 dval);
8570 }
14f9c5c9
AS
8571 else
8572 {
876cecd0 8573 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8574 return type0;
8575 }
8576
8577}
8578
8579/* An ordinary record type (with fixed-length fields) that describes
8580 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8581 union type. Any necessary discriminants' values should be in DVAL,
8582 a record value. That is, this routine selects the appropriate
8583 branch of the union at ADDR according to the discriminant value
b1f33ddd 8584 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8585 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8586
d2e4a39e 8587static struct type *
fc1a4b47 8588to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8589 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8590{
8591 int which;
d2e4a39e
AS
8592 struct type *templ_type;
8593 struct type *var_type;
14f9c5c9
AS
8594
8595 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8596 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8597 else
14f9c5c9
AS
8598 var_type = var_type0;
8599
8600 templ_type = ada_find_parallel_type (var_type, "___XVU");
8601
8602 if (templ_type != NULL)
8603 var_type = templ_type;
8604
b1f33ddd
JB
8605 if (is_unchecked_variant (var_type, value_type (dval)))
8606 return var_type0;
d2e4a39e
AS
8607 which =
8608 ada_which_variant_applies (var_type,
0fd88904 8609 value_type (dval), value_contents (dval));
14f9c5c9
AS
8610
8611 if (which < 0)
e9bb382b 8612 return empty_record (var_type);
14f9c5c9 8613 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8614 return to_fixed_record_type
d2e4a39e
AS
8615 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8616 valaddr, address, dval);
4c4b4cd2 8617 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8618 return
8619 to_fixed_record_type
8620 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8621 else
8622 return TYPE_FIELD_TYPE (var_type, which);
8623}
8624
8908fca5
JB
8625/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8626 ENCODING_TYPE, a type following the GNAT conventions for discrete
8627 type encodings, only carries redundant information. */
8628
8629static int
8630ada_is_redundant_range_encoding (struct type *range_type,
8631 struct type *encoding_type)
8632{
108d56a4 8633 const char *bounds_str;
8908fca5
JB
8634 int n;
8635 LONGEST lo, hi;
8636
8637 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8638
005e2509
JB
8639 if (TYPE_CODE (get_base_type (range_type))
8640 != TYPE_CODE (get_base_type (encoding_type)))
8641 {
8642 /* The compiler probably used a simple base type to describe
8643 the range type instead of the range's actual base type,
8644 expecting us to get the real base type from the encoding
8645 anyway. In this situation, the encoding cannot be ignored
8646 as redundant. */
8647 return 0;
8648 }
8649
8908fca5
JB
8650 if (is_dynamic_type (range_type))
8651 return 0;
8652
8653 if (TYPE_NAME (encoding_type) == NULL)
8654 return 0;
8655
8656 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8657 if (bounds_str == NULL)
8658 return 0;
8659
8660 n = 8; /* Skip "___XDLU_". */
8661 if (!ada_scan_number (bounds_str, n, &lo, &n))
8662 return 0;
8663 if (TYPE_LOW_BOUND (range_type) != lo)
8664 return 0;
8665
8666 n += 2; /* Skip the "__" separator between the two bounds. */
8667 if (!ada_scan_number (bounds_str, n, &hi, &n))
8668 return 0;
8669 if (TYPE_HIGH_BOUND (range_type) != hi)
8670 return 0;
8671
8672 return 1;
8673}
8674
8675/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8676 a type following the GNAT encoding for describing array type
8677 indices, only carries redundant information. */
8678
8679static int
8680ada_is_redundant_index_type_desc (struct type *array_type,
8681 struct type *desc_type)
8682{
8683 struct type *this_layer = check_typedef (array_type);
8684 int i;
8685
8686 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8687 {
8688 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8689 TYPE_FIELD_TYPE (desc_type, i)))
8690 return 0;
8691 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8692 }
8693
8694 return 1;
8695}
8696
14f9c5c9
AS
8697/* Assuming that TYPE0 is an array type describing the type of a value
8698 at ADDR, and that DVAL describes a record containing any
8699 discriminants used in TYPE0, returns a type for the value that
8700 contains no dynamic components (that is, no components whose sizes
8701 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8702 true, gives an error message if the resulting type's size is over
4c4b4cd2 8703 varsize_limit. */
14f9c5c9 8704
d2e4a39e
AS
8705static struct type *
8706to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8707 int ignore_too_big)
14f9c5c9 8708{
d2e4a39e
AS
8709 struct type *index_type_desc;
8710 struct type *result;
ad82864c 8711 int constrained_packed_array_p;
931e5bc3 8712 static const char *xa_suffix = "___XA";
14f9c5c9 8713
b0dd7688 8714 type0 = ada_check_typedef (type0);
284614f0 8715 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8716 return type0;
14f9c5c9 8717
ad82864c
JB
8718 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8719 if (constrained_packed_array_p)
8720 type0 = decode_constrained_packed_array_type (type0);
284614f0 8721
931e5bc3
JG
8722 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8723
8724 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8725 encoding suffixed with 'P' may still be generated. If so,
8726 it should be used to find the XA type. */
8727
8728 if (index_type_desc == NULL)
8729 {
1da0522e 8730 const char *type_name = ada_type_name (type0);
931e5bc3 8731
1da0522e 8732 if (type_name != NULL)
931e5bc3 8733 {
1da0522e 8734 const int len = strlen (type_name);
931e5bc3
JG
8735 char *name = (char *) alloca (len + strlen (xa_suffix));
8736
1da0522e 8737 if (type_name[len - 1] == 'P')
931e5bc3 8738 {
1da0522e 8739 strcpy (name, type_name);
931e5bc3
JG
8740 strcpy (name + len - 1, xa_suffix);
8741 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8742 }
8743 }
8744 }
8745
28c85d6c 8746 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8747 if (index_type_desc != NULL
8748 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8749 {
8750 /* Ignore this ___XA parallel type, as it does not bring any
8751 useful information. This allows us to avoid creating fixed
8752 versions of the array's index types, which would be identical
8753 to the original ones. This, in turn, can also help avoid
8754 the creation of fixed versions of the array itself. */
8755 index_type_desc = NULL;
8756 }
8757
14f9c5c9
AS
8758 if (index_type_desc == NULL)
8759 {
61ee279c 8760 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8761
14f9c5c9 8762 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8763 depend on the contents of the array in properly constructed
8764 debugging data. */
529cad9c
PH
8765 /* Create a fixed version of the array element type.
8766 We're not providing the address of an element here,
e1d5a0d2 8767 and thus the actual object value cannot be inspected to do
529cad9c
PH
8768 the conversion. This should not be a problem, since arrays of
8769 unconstrained objects are not allowed. In particular, all
8770 the elements of an array of a tagged type should all be of
8771 the same type specified in the debugging info. No need to
8772 consult the object tag. */
1ed6ede0 8773 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8774
284614f0
JB
8775 /* Make sure we always create a new array type when dealing with
8776 packed array types, since we're going to fix-up the array
8777 type length and element bitsize a little further down. */
ad82864c 8778 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8779 result = type0;
14f9c5c9 8780 else
e9bb382b 8781 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8782 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8783 }
8784 else
8785 {
8786 int i;
8787 struct type *elt_type0;
8788
8789 elt_type0 = type0;
8790 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8791 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8792
8793 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8794 depend on the contents of the array in properly constructed
8795 debugging data. */
529cad9c
PH
8796 /* Create a fixed version of the array element type.
8797 We're not providing the address of an element here,
e1d5a0d2 8798 and thus the actual object value cannot be inspected to do
529cad9c
PH
8799 the conversion. This should not be a problem, since arrays of
8800 unconstrained objects are not allowed. In particular, all
8801 the elements of an array of a tagged type should all be of
8802 the same type specified in the debugging info. No need to
8803 consult the object tag. */
1ed6ede0
JB
8804 result =
8805 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8806
8807 elt_type0 = type0;
14f9c5c9 8808 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8809 {
8810 struct type *range_type =
28c85d6c 8811 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8812
e9bb382b 8813 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8814 result, range_type);
1ce677a4 8815 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8816 }
d2e4a39e 8817 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8818 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8819 }
8820
2e6fda7d
JB
8821 /* We want to preserve the type name. This can be useful when
8822 trying to get the type name of a value that has already been
8823 printed (for instance, if the user did "print VAR; whatis $". */
8824 TYPE_NAME (result) = TYPE_NAME (type0);
8825
ad82864c 8826 if (constrained_packed_array_p)
284614f0
JB
8827 {
8828 /* So far, the resulting type has been created as if the original
8829 type was a regular (non-packed) array type. As a result, the
8830 bitsize of the array elements needs to be set again, and the array
8831 length needs to be recomputed based on that bitsize. */
8832 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8833 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8834
8835 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8836 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8837 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8838 TYPE_LENGTH (result)++;
8839 }
8840
876cecd0 8841 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8842 return result;
d2e4a39e 8843}
14f9c5c9
AS
8844
8845
8846/* A standard type (containing no dynamically sized components)
8847 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8848 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8849 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8850 ADDRESS or in VALADDR contains these discriminants.
8851
1ed6ede0
JB
8852 If CHECK_TAG is not null, in the case of tagged types, this function
8853 attempts to locate the object's tag and use it to compute the actual
8854 type. However, when ADDRESS is null, we cannot use it to determine the
8855 location of the tag, and therefore compute the tagged type's actual type.
8856 So we return the tagged type without consulting the tag. */
529cad9c 8857
f192137b
JB
8858static struct type *
8859ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8860 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8861{
61ee279c 8862 type = ada_check_typedef (type);
8ecb59f8
TT
8863
8864 /* Only un-fixed types need to be handled here. */
8865 if (!HAVE_GNAT_AUX_INFO (type))
8866 return type;
8867
d2e4a39e
AS
8868 switch (TYPE_CODE (type))
8869 {
8870 default:
14f9c5c9 8871 return type;
d2e4a39e 8872 case TYPE_CODE_STRUCT:
4c4b4cd2 8873 {
76a01679 8874 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8875 struct type *fixed_record_type =
8876 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8877
529cad9c
PH
8878 /* If STATIC_TYPE is a tagged type and we know the object's address,
8879 then we can determine its tag, and compute the object's actual
0963b4bd 8880 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8881 type (the parent part of the record may have dynamic fields
8882 and the way the location of _tag is expressed may depend on
8883 them). */
529cad9c 8884
1ed6ede0 8885 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8886 {
b50d69b5
JG
8887 struct value *tag =
8888 value_tag_from_contents_and_address
8889 (fixed_record_type,
8890 valaddr,
8891 address);
8892 struct type *real_type = type_from_tag (tag);
8893 struct value *obj =
8894 value_from_contents_and_address (fixed_record_type,
8895 valaddr,
8896 address);
9f1f738a 8897 fixed_record_type = value_type (obj);
76a01679 8898 if (real_type != NULL)
b50d69b5
JG
8899 return to_fixed_record_type
8900 (real_type, NULL,
8901 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8902 }
4af88198
JB
8903
8904 /* Check to see if there is a parallel ___XVZ variable.
8905 If there is, then it provides the actual size of our type. */
8906 else if (ada_type_name (fixed_record_type) != NULL)
8907 {
0d5cff50 8908 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
8909 char *xvz_name
8910 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 8911 bool xvz_found = false;
4af88198
JB
8912 LONGEST size;
8913
88c15c34 8914 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
a70b8144 8915 try
eccab96d
JB
8916 {
8917 xvz_found = get_int_var_value (xvz_name, size);
8918 }
230d2906 8919 catch (const gdb_exception_error &except)
eccab96d
JB
8920 {
8921 /* We found the variable, but somehow failed to read
8922 its value. Rethrow the same error, but with a little
8923 bit more information, to help the user understand
8924 what went wrong (Eg: the variable might have been
8925 optimized out). */
8926 throw_error (except.error,
8927 _("unable to read value of %s (%s)"),
3d6e9d23 8928 xvz_name, except.what ());
eccab96d 8929 }
eccab96d
JB
8930
8931 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
8932 {
8933 fixed_record_type = copy_type (fixed_record_type);
8934 TYPE_LENGTH (fixed_record_type) = size;
8935
8936 /* The FIXED_RECORD_TYPE may have be a stub. We have
8937 observed this when the debugging info is STABS, and
8938 apparently it is something that is hard to fix.
8939
8940 In practice, we don't need the actual type definition
8941 at all, because the presence of the XVZ variable allows us
8942 to assume that there must be a XVS type as well, which we
8943 should be able to use later, when we need the actual type
8944 definition.
8945
8946 In the meantime, pretend that the "fixed" type we are
8947 returning is NOT a stub, because this can cause trouble
8948 when using this type to create new types targeting it.
8949 Indeed, the associated creation routines often check
8950 whether the target type is a stub and will try to replace
0963b4bd 8951 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8952 might cause the new type to have the wrong size too.
8953 Consider the case of an array, for instance, where the size
8954 of the array is computed from the number of elements in
8955 our array multiplied by the size of its element. */
8956 TYPE_STUB (fixed_record_type) = 0;
8957 }
8958 }
1ed6ede0 8959 return fixed_record_type;
4c4b4cd2 8960 }
d2e4a39e 8961 case TYPE_CODE_ARRAY:
4c4b4cd2 8962 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8963 case TYPE_CODE_UNION:
8964 if (dval == NULL)
4c4b4cd2 8965 return type;
d2e4a39e 8966 else
4c4b4cd2 8967 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8968 }
14f9c5c9
AS
8969}
8970
f192137b
JB
8971/* The same as ada_to_fixed_type_1, except that it preserves the type
8972 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8973
8974 The typedef layer needs be preserved in order to differentiate between
8975 arrays and array pointers when both types are implemented using the same
8976 fat pointer. In the array pointer case, the pointer is encoded as
8977 a typedef of the pointer type. For instance, considering:
8978
8979 type String_Access is access String;
8980 S1 : String_Access := null;
8981
8982 To the debugger, S1 is defined as a typedef of type String. But
8983 to the user, it is a pointer. So if the user tries to print S1,
8984 we should not dereference the array, but print the array address
8985 instead.
8986
8987 If we didn't preserve the typedef layer, we would lose the fact that
8988 the type is to be presented as a pointer (needs de-reference before
8989 being printed). And we would also use the source-level type name. */
f192137b
JB
8990
8991struct type *
8992ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8993 CORE_ADDR address, struct value *dval, int check_tag)
8994
8995{
8996 struct type *fixed_type =
8997 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8998
96dbd2c1
JB
8999 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9000 then preserve the typedef layer.
9001
9002 Implementation note: We can only check the main-type portion of
9003 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9004 from TYPE now returns a type that has the same instance flags
9005 as TYPE. For instance, if TYPE is a "typedef const", and its
9006 target type is a "struct", then the typedef elimination will return
9007 a "const" version of the target type. See check_typedef for more
9008 details about how the typedef layer elimination is done.
9009
9010 brobecker/2010-11-19: It seems to me that the only case where it is
9011 useful to preserve the typedef layer is when dealing with fat pointers.
9012 Perhaps, we could add a check for that and preserve the typedef layer
9013 only in that situation. But this seems unecessary so far, probably
9014 because we call check_typedef/ada_check_typedef pretty much everywhere.
9015 */
f192137b 9016 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9017 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9018 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9019 return type;
9020
9021 return fixed_type;
9022}
9023
14f9c5c9 9024/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9025 TYPE0, but based on no runtime data. */
14f9c5c9 9026
d2e4a39e
AS
9027static struct type *
9028to_static_fixed_type (struct type *type0)
14f9c5c9 9029{
d2e4a39e 9030 struct type *type;
14f9c5c9
AS
9031
9032 if (type0 == NULL)
9033 return NULL;
9034
876cecd0 9035 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9036 return type0;
9037
61ee279c 9038 type0 = ada_check_typedef (type0);
d2e4a39e 9039
14f9c5c9
AS
9040 switch (TYPE_CODE (type0))
9041 {
9042 default:
9043 return type0;
9044 case TYPE_CODE_STRUCT:
9045 type = dynamic_template_type (type0);
d2e4a39e 9046 if (type != NULL)
4c4b4cd2
PH
9047 return template_to_static_fixed_type (type);
9048 else
9049 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9050 case TYPE_CODE_UNION:
9051 type = ada_find_parallel_type (type0, "___XVU");
9052 if (type != NULL)
4c4b4cd2
PH
9053 return template_to_static_fixed_type (type);
9054 else
9055 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9056 }
9057}
9058
4c4b4cd2
PH
9059/* A static approximation of TYPE with all type wrappers removed. */
9060
d2e4a39e
AS
9061static struct type *
9062static_unwrap_type (struct type *type)
14f9c5c9
AS
9063{
9064 if (ada_is_aligner_type (type))
9065 {
61ee279c 9066 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9067 if (ada_type_name (type1) == NULL)
4c4b4cd2 9068 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9069
9070 return static_unwrap_type (type1);
9071 }
d2e4a39e 9072 else
14f9c5c9 9073 {
d2e4a39e 9074 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9075
d2e4a39e 9076 if (raw_real_type == type)
4c4b4cd2 9077 return type;
14f9c5c9 9078 else
4c4b4cd2 9079 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9080 }
9081}
9082
9083/* In some cases, incomplete and private types require
4c4b4cd2 9084 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9085 type Foo;
9086 type FooP is access Foo;
9087 V: FooP;
9088 type Foo is array ...;
4c4b4cd2 9089 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9090 cross-references to such types, we instead substitute for FooP a
9091 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9092 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9093
9094/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9095 exists, otherwise TYPE. */
9096
d2e4a39e 9097struct type *
61ee279c 9098ada_check_typedef (struct type *type)
14f9c5c9 9099{
727e3d2e
JB
9100 if (type == NULL)
9101 return NULL;
9102
736ade86
XR
9103 /* If our type is an access to an unconstrained array, which is encoded
9104 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
720d1a40
JB
9105 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9106 what allows us to distinguish between fat pointers that represent
9107 array types, and fat pointers that represent array access types
9108 (in both cases, the compiler implements them as fat pointers). */
736ade86 9109 if (ada_is_access_to_unconstrained_array (type))
720d1a40
JB
9110 return type;
9111
f168693b 9112 type = check_typedef (type);
14f9c5c9 9113 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9114 || !TYPE_STUB (type)
e86ca25f 9115 || TYPE_NAME (type) == NULL)
14f9c5c9 9116 return type;
d2e4a39e 9117 else
14f9c5c9 9118 {
e86ca25f 9119 const char *name = TYPE_NAME (type);
d2e4a39e 9120 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9121
05e522ef
JB
9122 if (type1 == NULL)
9123 return type;
9124
9125 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9126 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9127 types, only for the typedef-to-array types). If that's the case,
9128 strip the typedef layer. */
9129 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9130 type1 = ada_check_typedef (type1);
9131
9132 return type1;
14f9c5c9
AS
9133 }
9134}
9135
9136/* A value representing the data at VALADDR/ADDRESS as described by
9137 type TYPE0, but with a standard (static-sized) type that correctly
9138 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9139 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9140 creation of struct values]. */
14f9c5c9 9141
4c4b4cd2
PH
9142static struct value *
9143ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9144 struct value *val0)
14f9c5c9 9145{
1ed6ede0 9146 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9147
14f9c5c9
AS
9148 if (type == type0 && val0 != NULL)
9149 return val0;
cc0e770c
JB
9150
9151 if (VALUE_LVAL (val0) != lval_memory)
9152 {
9153 /* Our value does not live in memory; it could be a convenience
9154 variable, for instance. Create a not_lval value using val0's
9155 contents. */
9156 return value_from_contents (type, value_contents (val0));
9157 }
9158
9159 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9160}
9161
9162/* A value representing VAL, but with a standard (static-sized) type
9163 that correctly describes it. Does not necessarily create a new
9164 value. */
9165
0c3acc09 9166struct value *
4c4b4cd2
PH
9167ada_to_fixed_value (struct value *val)
9168{
c48db5ca 9169 val = unwrap_value (val);
d8ce9127 9170 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
c48db5ca 9171 return val;
14f9c5c9 9172}
d2e4a39e 9173\f
14f9c5c9 9174
14f9c5c9
AS
9175/* Attributes */
9176
4c4b4cd2
PH
9177/* Table mapping attribute numbers to names.
9178 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9179
d2e4a39e 9180static const char *attribute_names[] = {
14f9c5c9
AS
9181 "<?>",
9182
d2e4a39e 9183 "first",
14f9c5c9
AS
9184 "last",
9185 "length",
9186 "image",
14f9c5c9
AS
9187 "max",
9188 "min",
4c4b4cd2
PH
9189 "modulus",
9190 "pos",
9191 "size",
9192 "tag",
14f9c5c9 9193 "val",
14f9c5c9
AS
9194 0
9195};
9196
d2e4a39e 9197const char *
4c4b4cd2 9198ada_attribute_name (enum exp_opcode n)
14f9c5c9 9199{
4c4b4cd2
PH
9200 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9201 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9202 else
9203 return attribute_names[0];
9204}
9205
4c4b4cd2 9206/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9207
4c4b4cd2
PH
9208static LONGEST
9209pos_atr (struct value *arg)
14f9c5c9 9210{
24209737
PH
9211 struct value *val = coerce_ref (arg);
9212 struct type *type = value_type (val);
aa715135 9213 LONGEST result;
14f9c5c9 9214
d2e4a39e 9215 if (!discrete_type_p (type))
323e0a4a 9216 error (_("'POS only defined on discrete types"));
14f9c5c9 9217
aa715135
JG
9218 if (!discrete_position (type, value_as_long (val), &result))
9219 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9220
aa715135 9221 return result;
4c4b4cd2
PH
9222}
9223
9224static struct value *
3cb382c9 9225value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9226{
3cb382c9 9227 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9228}
9229
4c4b4cd2 9230/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9231
d2e4a39e
AS
9232static struct value *
9233value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9234{
d2e4a39e 9235 if (!discrete_type_p (type))
323e0a4a 9236 error (_("'VAL only defined on discrete types"));
df407dfe 9237 if (!integer_type_p (value_type (arg)))
323e0a4a 9238 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9239
9240 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9241 {
9242 long pos = value_as_long (arg);
5b4ee69b 9243
14f9c5c9 9244 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9245 error (_("argument to 'VAL out of range"));
14e75d8e 9246 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9247 }
9248 else
9249 return value_from_longest (type, value_as_long (arg));
9250}
14f9c5c9 9251\f
d2e4a39e 9252
4c4b4cd2 9253 /* Evaluation */
14f9c5c9 9254
4c4b4cd2
PH
9255/* True if TYPE appears to be an Ada character type.
9256 [At the moment, this is true only for Character and Wide_Character;
9257 It is a heuristic test that could stand improvement]. */
14f9c5c9 9258
fc913e53 9259bool
d2e4a39e 9260ada_is_character_type (struct type *type)
14f9c5c9 9261{
7b9f71f2
JB
9262 const char *name;
9263
9264 /* If the type code says it's a character, then assume it really is,
9265 and don't check any further. */
9266 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
fc913e53 9267 return true;
7b9f71f2
JB
9268
9269 /* Otherwise, assume it's a character type iff it is a discrete type
9270 with a known character type name. */
9271 name = ada_type_name (type);
9272 return (name != NULL
9273 && (TYPE_CODE (type) == TYPE_CODE_INT
9274 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9275 && (strcmp (name, "character") == 0
9276 || strcmp (name, "wide_character") == 0
5a517ebd 9277 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9278 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9279}
9280
4c4b4cd2 9281/* True if TYPE appears to be an Ada string type. */
14f9c5c9 9282
fc913e53 9283bool
ebf56fd3 9284ada_is_string_type (struct type *type)
14f9c5c9 9285{
61ee279c 9286 type = ada_check_typedef (type);
d2e4a39e 9287 if (type != NULL
14f9c5c9 9288 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9289 && (ada_is_simple_array_type (type)
9290 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9291 && ada_array_arity (type) == 1)
9292 {
9293 struct type *elttype = ada_array_element_type (type, 1);
9294
9295 return ada_is_character_type (elttype);
9296 }
d2e4a39e 9297 else
fc913e53 9298 return false;
14f9c5c9
AS
9299}
9300
5bf03f13
JB
9301/* The compiler sometimes provides a parallel XVS type for a given
9302 PAD type. Normally, it is safe to follow the PAD type directly,
9303 but older versions of the compiler have a bug that causes the offset
9304 of its "F" field to be wrong. Following that field in that case
9305 would lead to incorrect results, but this can be worked around
9306 by ignoring the PAD type and using the associated XVS type instead.
9307
9308 Set to True if the debugger should trust the contents of PAD types.
9309 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9310static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9311
9312/* True if TYPE is a struct type introduced by the compiler to force the
9313 alignment of a value. Such types have a single field with a
4c4b4cd2 9314 distinctive name. */
14f9c5c9
AS
9315
9316int
ebf56fd3 9317ada_is_aligner_type (struct type *type)
14f9c5c9 9318{
61ee279c 9319 type = ada_check_typedef (type);
714e53ab 9320
5bf03f13 9321 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9322 return 0;
9323
14f9c5c9 9324 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9325 && TYPE_NFIELDS (type) == 1
9326 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9327}
9328
9329/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9330 the parallel type. */
14f9c5c9 9331
d2e4a39e
AS
9332struct type *
9333ada_get_base_type (struct type *raw_type)
14f9c5c9 9334{
d2e4a39e
AS
9335 struct type *real_type_namer;
9336 struct type *raw_real_type;
14f9c5c9
AS
9337
9338 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9339 return raw_type;
9340
284614f0
JB
9341 if (ada_is_aligner_type (raw_type))
9342 /* The encoding specifies that we should always use the aligner type.
9343 So, even if this aligner type has an associated XVS type, we should
9344 simply ignore it.
9345
9346 According to the compiler gurus, an XVS type parallel to an aligner
9347 type may exist because of a stabs limitation. In stabs, aligner
9348 types are empty because the field has a variable-sized type, and
9349 thus cannot actually be used as an aligner type. As a result,
9350 we need the associated parallel XVS type to decode the type.
9351 Since the policy in the compiler is to not change the internal
9352 representation based on the debugging info format, we sometimes
9353 end up having a redundant XVS type parallel to the aligner type. */
9354 return raw_type;
9355
14f9c5c9 9356 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9357 if (real_type_namer == NULL
14f9c5c9
AS
9358 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9359 || TYPE_NFIELDS (real_type_namer) != 1)
9360 return raw_type;
9361
f80d3ff2
JB
9362 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9363 {
9364 /* This is an older encoding form where the base type needs to be
9365 looked up by name. We prefer the newer enconding because it is
9366 more efficient. */
9367 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9368 if (raw_real_type == NULL)
9369 return raw_type;
9370 else
9371 return raw_real_type;
9372 }
9373
9374 /* The field in our XVS type is a reference to the base type. */
9375 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9376}
14f9c5c9 9377
4c4b4cd2 9378/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9379
d2e4a39e
AS
9380struct type *
9381ada_aligned_type (struct type *type)
14f9c5c9
AS
9382{
9383 if (ada_is_aligner_type (type))
9384 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9385 else
9386 return ada_get_base_type (type);
9387}
9388
9389
9390/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9391 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9392
fc1a4b47
AC
9393const gdb_byte *
9394ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9395{
d2e4a39e 9396 if (ada_is_aligner_type (type))
14f9c5c9 9397 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9398 valaddr +
9399 TYPE_FIELD_BITPOS (type,
9400 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9401 else
9402 return valaddr;
9403}
9404
4c4b4cd2
PH
9405
9406
14f9c5c9 9407/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9408 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9409const char *
9410ada_enum_name (const char *name)
14f9c5c9 9411{
4c4b4cd2
PH
9412 static char *result;
9413 static size_t result_len = 0;
e6a959d6 9414 const char *tmp;
14f9c5c9 9415
4c4b4cd2
PH
9416 /* First, unqualify the enumeration name:
9417 1. Search for the last '.' character. If we find one, then skip
177b42fe 9418 all the preceding characters, the unqualified name starts
76a01679 9419 right after that dot.
4c4b4cd2 9420 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9421 translates dots into "__". Search forward for double underscores,
9422 but stop searching when we hit an overloading suffix, which is
9423 of the form "__" followed by digits. */
4c4b4cd2 9424
c3e5cd34
PH
9425 tmp = strrchr (name, '.');
9426 if (tmp != NULL)
4c4b4cd2
PH
9427 name = tmp + 1;
9428 else
14f9c5c9 9429 {
4c4b4cd2
PH
9430 while ((tmp = strstr (name, "__")) != NULL)
9431 {
9432 if (isdigit (tmp[2]))
9433 break;
9434 else
9435 name = tmp + 2;
9436 }
14f9c5c9
AS
9437 }
9438
9439 if (name[0] == 'Q')
9440 {
14f9c5c9 9441 int v;
5b4ee69b 9442
14f9c5c9 9443 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9444 {
9445 if (sscanf (name + 2, "%x", &v) != 1)
9446 return name;
9447 }
14f9c5c9 9448 else
4c4b4cd2 9449 return name;
14f9c5c9 9450
4c4b4cd2 9451 GROW_VECT (result, result_len, 16);
14f9c5c9 9452 if (isascii (v) && isprint (v))
88c15c34 9453 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9454 else if (name[1] == 'U')
88c15c34 9455 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9456 else
88c15c34 9457 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9458
9459 return result;
9460 }
d2e4a39e 9461 else
4c4b4cd2 9462 {
c3e5cd34
PH
9463 tmp = strstr (name, "__");
9464 if (tmp == NULL)
9465 tmp = strstr (name, "$");
9466 if (tmp != NULL)
4c4b4cd2
PH
9467 {
9468 GROW_VECT (result, result_len, tmp - name + 1);
9469 strncpy (result, name, tmp - name);
9470 result[tmp - name] = '\0';
9471 return result;
9472 }
9473
9474 return name;
9475 }
14f9c5c9
AS
9476}
9477
14f9c5c9
AS
9478/* Evaluate the subexpression of EXP starting at *POS as for
9479 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9480 expression. */
14f9c5c9 9481
d2e4a39e
AS
9482static struct value *
9483evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9484{
4b27a620 9485 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9486}
9487
9488/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9489 value it wraps. */
14f9c5c9 9490
d2e4a39e
AS
9491static struct value *
9492unwrap_value (struct value *val)
14f9c5c9 9493{
df407dfe 9494 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9495
14f9c5c9
AS
9496 if (ada_is_aligner_type (type))
9497 {
de4d072f 9498 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9499 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9500
14f9c5c9 9501 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9502 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9503
9504 return unwrap_value (v);
9505 }
d2e4a39e 9506 else
14f9c5c9 9507 {
d2e4a39e 9508 struct type *raw_real_type =
61ee279c 9509 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9510
5bf03f13
JB
9511 /* If there is no parallel XVS or XVE type, then the value is
9512 already unwrapped. Return it without further modification. */
9513 if ((type == raw_real_type)
9514 && ada_find_parallel_type (type, "___XVE") == NULL)
9515 return val;
14f9c5c9 9516
d2e4a39e 9517 return
4c4b4cd2
PH
9518 coerce_unspec_val_to_type
9519 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9520 value_address (val),
1ed6ede0 9521 NULL, 1));
14f9c5c9
AS
9522 }
9523}
d2e4a39e
AS
9524
9525static struct value *
50eff16b 9526cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9527{
50eff16b
UW
9528 struct value *scale = ada_scaling_factor (value_type (arg));
9529 arg = value_cast (value_type (scale), arg);
14f9c5c9 9530
50eff16b
UW
9531 arg = value_binop (arg, scale, BINOP_MUL);
9532 return value_cast (type, arg);
14f9c5c9
AS
9533}
9534
d2e4a39e 9535static struct value *
50eff16b 9536cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9537{
50eff16b
UW
9538 if (type == value_type (arg))
9539 return arg;
5b4ee69b 9540
50eff16b
UW
9541 struct value *scale = ada_scaling_factor (type);
9542 if (ada_is_fixed_point_type (value_type (arg)))
9543 arg = cast_from_fixed (value_type (scale), arg);
9544 else
9545 arg = value_cast (value_type (scale), arg);
9546
9547 arg = value_binop (arg, scale, BINOP_DIV);
9548 return value_cast (type, arg);
14f9c5c9
AS
9549}
9550
d99dcf51
JB
9551/* Given two array types T1 and T2, return nonzero iff both arrays
9552 contain the same number of elements. */
9553
9554static int
9555ada_same_array_size_p (struct type *t1, struct type *t2)
9556{
9557 LONGEST lo1, hi1, lo2, hi2;
9558
9559 /* Get the array bounds in order to verify that the size of
9560 the two arrays match. */
9561 if (!get_array_bounds (t1, &lo1, &hi1)
9562 || !get_array_bounds (t2, &lo2, &hi2))
9563 error (_("unable to determine array bounds"));
9564
9565 /* To make things easier for size comparison, normalize a bit
9566 the case of empty arrays by making sure that the difference
9567 between upper bound and lower bound is always -1. */
9568 if (lo1 > hi1)
9569 hi1 = lo1 - 1;
9570 if (lo2 > hi2)
9571 hi2 = lo2 - 1;
9572
9573 return (hi1 - lo1 == hi2 - lo2);
9574}
9575
9576/* Assuming that VAL is an array of integrals, and TYPE represents
9577 an array with the same number of elements, but with wider integral
9578 elements, return an array "casted" to TYPE. In practice, this
9579 means that the returned array is built by casting each element
9580 of the original array into TYPE's (wider) element type. */
9581
9582static struct value *
9583ada_promote_array_of_integrals (struct type *type, struct value *val)
9584{
9585 struct type *elt_type = TYPE_TARGET_TYPE (type);
9586 LONGEST lo, hi;
9587 struct value *res;
9588 LONGEST i;
9589
9590 /* Verify that both val and type are arrays of scalars, and
9591 that the size of val's elements is smaller than the size
9592 of type's element. */
9593 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9594 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9595 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9596 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9597 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9598 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9599
9600 if (!get_array_bounds (type, &lo, &hi))
9601 error (_("unable to determine array bounds"));
9602
9603 res = allocate_value (type);
9604
9605 /* Promote each array element. */
9606 for (i = 0; i < hi - lo + 1; i++)
9607 {
9608 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9609
9610 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9611 value_contents_all (elt), TYPE_LENGTH (elt_type));
9612 }
9613
9614 return res;
9615}
9616
4c4b4cd2
PH
9617/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9618 return the converted value. */
9619
d2e4a39e
AS
9620static struct value *
9621coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9622{
df407dfe 9623 struct type *type2 = value_type (val);
5b4ee69b 9624
14f9c5c9
AS
9625 if (type == type2)
9626 return val;
9627
61ee279c
PH
9628 type2 = ada_check_typedef (type2);
9629 type = ada_check_typedef (type);
14f9c5c9 9630
d2e4a39e
AS
9631 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9632 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9633 {
9634 val = ada_value_ind (val);
df407dfe 9635 type2 = value_type (val);
14f9c5c9
AS
9636 }
9637
d2e4a39e 9638 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9639 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9640 {
d99dcf51
JB
9641 if (!ada_same_array_size_p (type, type2))
9642 error (_("cannot assign arrays of different length"));
9643
9644 if (is_integral_type (TYPE_TARGET_TYPE (type))
9645 && is_integral_type (TYPE_TARGET_TYPE (type2))
9646 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9647 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9648 {
9649 /* Allow implicit promotion of the array elements to
9650 a wider type. */
9651 return ada_promote_array_of_integrals (type, val);
9652 }
9653
9654 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9655 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9656 error (_("Incompatible types in assignment"));
04624583 9657 deprecated_set_value_type (val, type);
14f9c5c9 9658 }
d2e4a39e 9659 return val;
14f9c5c9
AS
9660}
9661
4c4b4cd2
PH
9662static struct value *
9663ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9664{
9665 struct value *val;
9666 struct type *type1, *type2;
9667 LONGEST v, v1, v2;
9668
994b9211
AC
9669 arg1 = coerce_ref (arg1);
9670 arg2 = coerce_ref (arg2);
18af8284
JB
9671 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9672 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9673
76a01679
JB
9674 if (TYPE_CODE (type1) != TYPE_CODE_INT
9675 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9676 return value_binop (arg1, arg2, op);
9677
76a01679 9678 switch (op)
4c4b4cd2
PH
9679 {
9680 case BINOP_MOD:
9681 case BINOP_DIV:
9682 case BINOP_REM:
9683 break;
9684 default:
9685 return value_binop (arg1, arg2, op);
9686 }
9687
9688 v2 = value_as_long (arg2);
9689 if (v2 == 0)
323e0a4a 9690 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9691
9692 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9693 return value_binop (arg1, arg2, op);
9694
9695 v1 = value_as_long (arg1);
9696 switch (op)
9697 {
9698 case BINOP_DIV:
9699 v = v1 / v2;
76a01679
JB
9700 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9701 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9702 break;
9703 case BINOP_REM:
9704 v = v1 % v2;
76a01679
JB
9705 if (v * v1 < 0)
9706 v -= v2;
4c4b4cd2
PH
9707 break;
9708 default:
9709 /* Should not reach this point. */
9710 v = 0;
9711 }
9712
9713 val = allocate_value (type1);
990a07ab 9714 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9715 TYPE_LENGTH (value_type (val)),
9716 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9717 return val;
9718}
9719
9720static int
9721ada_value_equal (struct value *arg1, struct value *arg2)
9722{
df407dfe
AC
9723 if (ada_is_direct_array_type (value_type (arg1))
9724 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9725 {
79e8fcaa
JB
9726 struct type *arg1_type, *arg2_type;
9727
f58b38bf
JB
9728 /* Automatically dereference any array reference before
9729 we attempt to perform the comparison. */
9730 arg1 = ada_coerce_ref (arg1);
9731 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9732
4c4b4cd2
PH
9733 arg1 = ada_coerce_to_simple_array (arg1);
9734 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9735
9736 arg1_type = ada_check_typedef (value_type (arg1));
9737 arg2_type = ada_check_typedef (value_type (arg2));
9738
9739 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9740 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9741 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9742 /* FIXME: The following works only for types whose
76a01679
JB
9743 representations use all bits (no padding or undefined bits)
9744 and do not have user-defined equality. */
79e8fcaa
JB
9745 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9746 && memcmp (value_contents (arg1), value_contents (arg2),
9747 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9748 }
9749 return value_equal (arg1, arg2);
9750}
9751
52ce6436
PH
9752/* Total number of component associations in the aggregate starting at
9753 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9754 OP_AGGREGATE. */
52ce6436
PH
9755
9756static int
9757num_component_specs (struct expression *exp, int pc)
9758{
9759 int n, m, i;
5b4ee69b 9760
52ce6436
PH
9761 m = exp->elts[pc + 1].longconst;
9762 pc += 3;
9763 n = 0;
9764 for (i = 0; i < m; i += 1)
9765 {
9766 switch (exp->elts[pc].opcode)
9767 {
9768 default:
9769 n += 1;
9770 break;
9771 case OP_CHOICES:
9772 n += exp->elts[pc + 1].longconst;
9773 break;
9774 }
9775 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9776 }
9777 return n;
9778}
9779
9780/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9781 component of LHS (a simple array or a record), updating *POS past
9782 the expression, assuming that LHS is contained in CONTAINER. Does
9783 not modify the inferior's memory, nor does it modify LHS (unless
9784 LHS == CONTAINER). */
9785
9786static void
9787assign_component (struct value *container, struct value *lhs, LONGEST index,
9788 struct expression *exp, int *pos)
9789{
9790 struct value *mark = value_mark ();
9791 struct value *elt;
0e2da9f0 9792 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9793
0e2da9f0 9794 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9795 {
22601c15
UW
9796 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9797 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9798
52ce6436
PH
9799 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9800 }
9801 else
9802 {
9803 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9804 elt = ada_to_fixed_value (elt);
52ce6436
PH
9805 }
9806
9807 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9808 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9809 else
9810 value_assign_to_component (container, elt,
9811 ada_evaluate_subexp (NULL, exp, pos,
9812 EVAL_NORMAL));
9813
9814 value_free_to_mark (mark);
9815}
9816
9817/* Assuming that LHS represents an lvalue having a record or array
9818 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9819 of that aggregate's value to LHS, advancing *POS past the
9820 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9821 lvalue containing LHS (possibly LHS itself). Does not modify
9822 the inferior's memory, nor does it modify the contents of
0963b4bd 9823 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9824
9825static struct value *
9826assign_aggregate (struct value *container,
9827 struct value *lhs, struct expression *exp,
9828 int *pos, enum noside noside)
9829{
9830 struct type *lhs_type;
9831 int n = exp->elts[*pos+1].longconst;
9832 LONGEST low_index, high_index;
9833 int num_specs;
9834 LONGEST *indices;
9835 int max_indices, num_indices;
52ce6436 9836 int i;
52ce6436
PH
9837
9838 *pos += 3;
9839 if (noside != EVAL_NORMAL)
9840 {
52ce6436
PH
9841 for (i = 0; i < n; i += 1)
9842 ada_evaluate_subexp (NULL, exp, pos, noside);
9843 return container;
9844 }
9845
9846 container = ada_coerce_ref (container);
9847 if (ada_is_direct_array_type (value_type (container)))
9848 container = ada_coerce_to_simple_array (container);
9849 lhs = ada_coerce_ref (lhs);
9850 if (!deprecated_value_modifiable (lhs))
9851 error (_("Left operand of assignment is not a modifiable lvalue."));
9852
0e2da9f0 9853 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9854 if (ada_is_direct_array_type (lhs_type))
9855 {
9856 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 9857 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9858 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9859 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9860 }
9861 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9862 {
9863 low_index = 0;
9864 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9865 }
9866 else
9867 error (_("Left-hand side must be array or record."));
9868
9869 num_specs = num_component_specs (exp, *pos - 3);
9870 max_indices = 4 * num_specs + 4;
8d749320 9871 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
9872 indices[0] = indices[1] = low_index - 1;
9873 indices[2] = indices[3] = high_index + 1;
9874 num_indices = 4;
9875
9876 for (i = 0; i < n; i += 1)
9877 {
9878 switch (exp->elts[*pos].opcode)
9879 {
1fbf5ada
JB
9880 case OP_CHOICES:
9881 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9882 &num_indices, max_indices,
9883 low_index, high_index);
9884 break;
9885 case OP_POSITIONAL:
9886 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9887 &num_indices, max_indices,
9888 low_index, high_index);
1fbf5ada
JB
9889 break;
9890 case OP_OTHERS:
9891 if (i != n-1)
9892 error (_("Misplaced 'others' clause"));
9893 aggregate_assign_others (container, lhs, exp, pos, indices,
9894 num_indices, low_index, high_index);
9895 break;
9896 default:
9897 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9898 }
9899 }
9900
9901 return container;
9902}
9903
9904/* Assign into the component of LHS indexed by the OP_POSITIONAL
9905 construct at *POS, updating *POS past the construct, given that
9906 the positions are relative to lower bound LOW, where HIGH is the
9907 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9908 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9909 assign_aggregate. */
52ce6436
PH
9910static void
9911aggregate_assign_positional (struct value *container,
9912 struct value *lhs, struct expression *exp,
9913 int *pos, LONGEST *indices, int *num_indices,
9914 int max_indices, LONGEST low, LONGEST high)
9915{
9916 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9917
9918 if (ind - 1 == high)
e1d5a0d2 9919 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9920 if (ind <= high)
9921 {
9922 add_component_interval (ind, ind, indices, num_indices, max_indices);
9923 *pos += 3;
9924 assign_component (container, lhs, ind, exp, pos);
9925 }
9926 else
9927 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9928}
9929
9930/* Assign into the components of LHS indexed by the OP_CHOICES
9931 construct at *POS, updating *POS past the construct, given that
9932 the allowable indices are LOW..HIGH. Record the indices assigned
9933 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9934 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9935static void
9936aggregate_assign_from_choices (struct value *container,
9937 struct value *lhs, struct expression *exp,
9938 int *pos, LONGEST *indices, int *num_indices,
9939 int max_indices, LONGEST low, LONGEST high)
9940{
9941 int j;
9942 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9943 int choice_pos, expr_pc;
9944 int is_array = ada_is_direct_array_type (value_type (lhs));
9945
9946 choice_pos = *pos += 3;
9947
9948 for (j = 0; j < n_choices; j += 1)
9949 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9950 expr_pc = *pos;
9951 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9952
9953 for (j = 0; j < n_choices; j += 1)
9954 {
9955 LONGEST lower, upper;
9956 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9957
52ce6436
PH
9958 if (op == OP_DISCRETE_RANGE)
9959 {
9960 choice_pos += 1;
9961 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9962 EVAL_NORMAL));
9963 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9964 EVAL_NORMAL));
9965 }
9966 else if (is_array)
9967 {
9968 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9969 EVAL_NORMAL));
9970 upper = lower;
9971 }
9972 else
9973 {
9974 int ind;
0d5cff50 9975 const char *name;
5b4ee69b 9976
52ce6436
PH
9977 switch (op)
9978 {
9979 case OP_NAME:
9980 name = &exp->elts[choice_pos + 2].string;
9981 break;
9982 case OP_VAR_VALUE:
9983 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9984 break;
9985 default:
9986 error (_("Invalid record component association."));
9987 }
9988 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9989 ind = 0;
9990 if (! find_struct_field (name, value_type (lhs), 0,
9991 NULL, NULL, NULL, NULL, &ind))
9992 error (_("Unknown component name: %s."), name);
9993 lower = upper = ind;
9994 }
9995
9996 if (lower <= upper && (lower < low || upper > high))
9997 error (_("Index in component association out of bounds."));
9998
9999 add_component_interval (lower, upper, indices, num_indices,
10000 max_indices);
10001 while (lower <= upper)
10002 {
10003 int pos1;
5b4ee69b 10004
52ce6436
PH
10005 pos1 = expr_pc;
10006 assign_component (container, lhs, lower, exp, &pos1);
10007 lower += 1;
10008 }
10009 }
10010}
10011
10012/* Assign the value of the expression in the OP_OTHERS construct in
10013 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10014 have not been previously assigned. The index intervals already assigned
10015 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10016 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10017static void
10018aggregate_assign_others (struct value *container,
10019 struct value *lhs, struct expression *exp,
10020 int *pos, LONGEST *indices, int num_indices,
10021 LONGEST low, LONGEST high)
10022{
10023 int i;
5ce64950 10024 int expr_pc = *pos + 1;
52ce6436
PH
10025
10026 for (i = 0; i < num_indices - 2; i += 2)
10027 {
10028 LONGEST ind;
5b4ee69b 10029
52ce6436
PH
10030 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10031 {
5ce64950 10032 int localpos;
5b4ee69b 10033
5ce64950
MS
10034 localpos = expr_pc;
10035 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10036 }
10037 }
10038 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10039}
10040
10041/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10042 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10043 modifying *SIZE as needed. It is an error if *SIZE exceeds
10044 MAX_SIZE. The resulting intervals do not overlap. */
10045static void
10046add_component_interval (LONGEST low, LONGEST high,
10047 LONGEST* indices, int *size, int max_size)
10048{
10049 int i, j;
5b4ee69b 10050
52ce6436
PH
10051 for (i = 0; i < *size; i += 2) {
10052 if (high >= indices[i] && low <= indices[i + 1])
10053 {
10054 int kh;
5b4ee69b 10055
52ce6436
PH
10056 for (kh = i + 2; kh < *size; kh += 2)
10057 if (high < indices[kh])
10058 break;
10059 if (low < indices[i])
10060 indices[i] = low;
10061 indices[i + 1] = indices[kh - 1];
10062 if (high > indices[i + 1])
10063 indices[i + 1] = high;
10064 memcpy (indices + i + 2, indices + kh, *size - kh);
10065 *size -= kh - i - 2;
10066 return;
10067 }
10068 else if (high < indices[i])
10069 break;
10070 }
10071
10072 if (*size == max_size)
10073 error (_("Internal error: miscounted aggregate components."));
10074 *size += 2;
10075 for (j = *size-1; j >= i+2; j -= 1)
10076 indices[j] = indices[j - 2];
10077 indices[i] = low;
10078 indices[i + 1] = high;
10079}
10080
6e48bd2c
JB
10081/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10082 is different. */
10083
10084static struct value *
b7e22850 10085ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10086{
10087 if (type == ada_check_typedef (value_type (arg2)))
10088 return arg2;
10089
10090 if (ada_is_fixed_point_type (type))
95f39a5b 10091 return cast_to_fixed (type, arg2);
6e48bd2c
JB
10092
10093 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10094 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10095
10096 return value_cast (type, arg2);
10097}
10098
284614f0
JB
10099/* Evaluating Ada expressions, and printing their result.
10100 ------------------------------------------------------
10101
21649b50
JB
10102 1. Introduction:
10103 ----------------
10104
284614f0
JB
10105 We usually evaluate an Ada expression in order to print its value.
10106 We also evaluate an expression in order to print its type, which
10107 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10108 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10109 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10110 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10111 similar.
10112
10113 Evaluating expressions is a little more complicated for Ada entities
10114 than it is for entities in languages such as C. The main reason for
10115 this is that Ada provides types whose definition might be dynamic.
10116 One example of such types is variant records. Or another example
10117 would be an array whose bounds can only be known at run time.
10118
10119 The following description is a general guide as to what should be
10120 done (and what should NOT be done) in order to evaluate an expression
10121 involving such types, and when. This does not cover how the semantic
10122 information is encoded by GNAT as this is covered separatly. For the
10123 document used as the reference for the GNAT encoding, see exp_dbug.ads
10124 in the GNAT sources.
10125
10126 Ideally, we should embed each part of this description next to its
10127 associated code. Unfortunately, the amount of code is so vast right
10128 now that it's hard to see whether the code handling a particular
10129 situation might be duplicated or not. One day, when the code is
10130 cleaned up, this guide might become redundant with the comments
10131 inserted in the code, and we might want to remove it.
10132
21649b50
JB
10133 2. ``Fixing'' an Entity, the Simple Case:
10134 -----------------------------------------
10135
284614f0
JB
10136 When evaluating Ada expressions, the tricky issue is that they may
10137 reference entities whose type contents and size are not statically
10138 known. Consider for instance a variant record:
10139
10140 type Rec (Empty : Boolean := True) is record
10141 case Empty is
10142 when True => null;
10143 when False => Value : Integer;
10144 end case;
10145 end record;
10146 Yes : Rec := (Empty => False, Value => 1);
10147 No : Rec := (empty => True);
10148
10149 The size and contents of that record depends on the value of the
10150 descriminant (Rec.Empty). At this point, neither the debugging
10151 information nor the associated type structure in GDB are able to
10152 express such dynamic types. So what the debugger does is to create
10153 "fixed" versions of the type that applies to the specific object.
10154 We also informally refer to this opperation as "fixing" an object,
10155 which means creating its associated fixed type.
10156
10157 Example: when printing the value of variable "Yes" above, its fixed
10158 type would look like this:
10159
10160 type Rec is record
10161 Empty : Boolean;
10162 Value : Integer;
10163 end record;
10164
10165 On the other hand, if we printed the value of "No", its fixed type
10166 would become:
10167
10168 type Rec is record
10169 Empty : Boolean;
10170 end record;
10171
10172 Things become a little more complicated when trying to fix an entity
10173 with a dynamic type that directly contains another dynamic type,
10174 such as an array of variant records, for instance. There are
10175 two possible cases: Arrays, and records.
10176
21649b50
JB
10177 3. ``Fixing'' Arrays:
10178 ---------------------
10179
10180 The type structure in GDB describes an array in terms of its bounds,
10181 and the type of its elements. By design, all elements in the array
10182 have the same type and we cannot represent an array of variant elements
10183 using the current type structure in GDB. When fixing an array,
10184 we cannot fix the array element, as we would potentially need one
10185 fixed type per element of the array. As a result, the best we can do
10186 when fixing an array is to produce an array whose bounds and size
10187 are correct (allowing us to read it from memory), but without having
10188 touched its element type. Fixing each element will be done later,
10189 when (if) necessary.
10190
10191 Arrays are a little simpler to handle than records, because the same
10192 amount of memory is allocated for each element of the array, even if
1b536f04 10193 the amount of space actually used by each element differs from element
21649b50 10194 to element. Consider for instance the following array of type Rec:
284614f0
JB
10195
10196 type Rec_Array is array (1 .. 2) of Rec;
10197
1b536f04
JB
10198 The actual amount of memory occupied by each element might be different
10199 from element to element, depending on the value of their discriminant.
21649b50 10200 But the amount of space reserved for each element in the array remains
1b536f04 10201 fixed regardless. So we simply need to compute that size using
21649b50
JB
10202 the debugging information available, from which we can then determine
10203 the array size (we multiply the number of elements of the array by
10204 the size of each element).
10205
10206 The simplest case is when we have an array of a constrained element
10207 type. For instance, consider the following type declarations:
10208
10209 type Bounded_String (Max_Size : Integer) is
10210 Length : Integer;
10211 Buffer : String (1 .. Max_Size);
10212 end record;
10213 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10214
10215 In this case, the compiler describes the array as an array of
10216 variable-size elements (identified by its XVS suffix) for which
10217 the size can be read in the parallel XVZ variable.
10218
10219 In the case of an array of an unconstrained element type, the compiler
10220 wraps the array element inside a private PAD type. This type should not
10221 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10222 that we also use the adjective "aligner" in our code to designate
10223 these wrapper types.
10224
1b536f04 10225 In some cases, the size allocated for each element is statically
21649b50
JB
10226 known. In that case, the PAD type already has the correct size,
10227 and the array element should remain unfixed.
10228
10229 But there are cases when this size is not statically known.
10230 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10231
10232 type Dynamic is array (1 .. Five) of Integer;
10233 type Wrapper (Has_Length : Boolean := False) is record
10234 Data : Dynamic;
10235 case Has_Length is
10236 when True => Length : Integer;
10237 when False => null;
10238 end case;
10239 end record;
10240 type Wrapper_Array is array (1 .. 2) of Wrapper;
10241
10242 Hello : Wrapper_Array := (others => (Has_Length => True,
10243 Data => (others => 17),
10244 Length => 1));
10245
10246
10247 The debugging info would describe variable Hello as being an
10248 array of a PAD type. The size of that PAD type is not statically
10249 known, but can be determined using a parallel XVZ variable.
10250 In that case, a copy of the PAD type with the correct size should
10251 be used for the fixed array.
10252
21649b50
JB
10253 3. ``Fixing'' record type objects:
10254 ----------------------------------
10255
10256 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10257 record types. In this case, in order to compute the associated
10258 fixed type, we need to determine the size and offset of each of
10259 its components. This, in turn, requires us to compute the fixed
10260 type of each of these components.
10261
10262 Consider for instance the example:
10263
10264 type Bounded_String (Max_Size : Natural) is record
10265 Str : String (1 .. Max_Size);
10266 Length : Natural;
10267 end record;
10268 My_String : Bounded_String (Max_Size => 10);
10269
10270 In that case, the position of field "Length" depends on the size
10271 of field Str, which itself depends on the value of the Max_Size
21649b50 10272 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10273 we need to fix the type of field Str. Therefore, fixing a variant
10274 record requires us to fix each of its components.
10275
10276 However, if a component does not have a dynamic size, the component
10277 should not be fixed. In particular, fields that use a PAD type
10278 should not fixed. Here is an example where this might happen
10279 (assuming type Rec above):
10280
10281 type Container (Big : Boolean) is record
10282 First : Rec;
10283 After : Integer;
10284 case Big is
10285 when True => Another : Integer;
10286 when False => null;
10287 end case;
10288 end record;
10289 My_Container : Container := (Big => False,
10290 First => (Empty => True),
10291 After => 42);
10292
10293 In that example, the compiler creates a PAD type for component First,
10294 whose size is constant, and then positions the component After just
10295 right after it. The offset of component After is therefore constant
10296 in this case.
10297
10298 The debugger computes the position of each field based on an algorithm
10299 that uses, among other things, the actual position and size of the field
21649b50
JB
10300 preceding it. Let's now imagine that the user is trying to print
10301 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10302 end up computing the offset of field After based on the size of the
10303 fixed version of field First. And since in our example First has
10304 only one actual field, the size of the fixed type is actually smaller
10305 than the amount of space allocated to that field, and thus we would
10306 compute the wrong offset of field After.
10307
21649b50
JB
10308 To make things more complicated, we need to watch out for dynamic
10309 components of variant records (identified by the ___XVL suffix in
10310 the component name). Even if the target type is a PAD type, the size
10311 of that type might not be statically known. So the PAD type needs
10312 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10313 we might end up with the wrong size for our component. This can be
10314 observed with the following type declarations:
284614f0
JB
10315
10316 type Octal is new Integer range 0 .. 7;
10317 type Octal_Array is array (Positive range <>) of Octal;
10318 pragma Pack (Octal_Array);
10319
10320 type Octal_Buffer (Size : Positive) is record
10321 Buffer : Octal_Array (1 .. Size);
10322 Length : Integer;
10323 end record;
10324
10325 In that case, Buffer is a PAD type whose size is unset and needs
10326 to be computed by fixing the unwrapped type.
10327
21649b50
JB
10328 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10329 ----------------------------------------------------------
10330
10331 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10332 thus far, be actually fixed?
10333
10334 The answer is: Only when referencing that element. For instance
10335 when selecting one component of a record, this specific component
10336 should be fixed at that point in time. Or when printing the value
10337 of a record, each component should be fixed before its value gets
10338 printed. Similarly for arrays, the element of the array should be
10339 fixed when printing each element of the array, or when extracting
10340 one element out of that array. On the other hand, fixing should
10341 not be performed on the elements when taking a slice of an array!
10342
31432a67 10343 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10344 size of each field is that we end up also miscomputing the size
10345 of the containing type. This can have adverse results when computing
10346 the value of an entity. GDB fetches the value of an entity based
10347 on the size of its type, and thus a wrong size causes GDB to fetch
10348 the wrong amount of memory. In the case where the computed size is
10349 too small, GDB fetches too little data to print the value of our
31432a67 10350 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10351 past the buffer containing the data =:-o. */
10352
ced9779b
JB
10353/* Evaluate a subexpression of EXP, at index *POS, and return a value
10354 for that subexpression cast to TO_TYPE. Advance *POS over the
10355 subexpression. */
10356
10357static value *
10358ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10359 enum noside noside, struct type *to_type)
10360{
10361 int pc = *pos;
10362
10363 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10364 || exp->elts[pc].opcode == OP_VAR_VALUE)
10365 {
10366 (*pos) += 4;
10367
10368 value *val;
10369 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10370 {
10371 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10372 return value_zero (to_type, not_lval);
10373
10374 val = evaluate_var_msym_value (noside,
10375 exp->elts[pc + 1].objfile,
10376 exp->elts[pc + 2].msymbol);
10377 }
10378 else
10379 val = evaluate_var_value (noside,
10380 exp->elts[pc + 1].block,
10381 exp->elts[pc + 2].symbol);
10382
10383 if (noside == EVAL_SKIP)
10384 return eval_skip_value (exp);
10385
10386 val = ada_value_cast (to_type, val);
10387
10388 /* Follow the Ada language semantics that do not allow taking
10389 an address of the result of a cast (view conversion in Ada). */
10390 if (VALUE_LVAL (val) == lval_memory)
10391 {
10392 if (value_lazy (val))
10393 value_fetch_lazy (val);
10394 VALUE_LVAL (val) = not_lval;
10395 }
10396 return val;
10397 }
10398
10399 value *val = evaluate_subexp (to_type, exp, pos, noside);
10400 if (noside == EVAL_SKIP)
10401 return eval_skip_value (exp);
10402 return ada_value_cast (to_type, val);
10403}
10404
284614f0
JB
10405/* Implement the evaluate_exp routine in the exp_descriptor structure
10406 for the Ada language. */
10407
52ce6436 10408static struct value *
ebf56fd3 10409ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10410 int *pos, enum noside noside)
14f9c5c9
AS
10411{
10412 enum exp_opcode op;
b5385fc0 10413 int tem;
14f9c5c9 10414 int pc;
5ec18f2b 10415 int preeval_pos;
14f9c5c9
AS
10416 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10417 struct type *type;
52ce6436 10418 int nargs, oplen;
d2e4a39e 10419 struct value **argvec;
14f9c5c9 10420
d2e4a39e
AS
10421 pc = *pos;
10422 *pos += 1;
14f9c5c9
AS
10423 op = exp->elts[pc].opcode;
10424
d2e4a39e 10425 switch (op)
14f9c5c9
AS
10426 {
10427 default:
10428 *pos -= 1;
6e48bd2c 10429 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10430
10431 if (noside == EVAL_NORMAL)
10432 arg1 = unwrap_value (arg1);
6e48bd2c 10433
edd079d9 10434 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10435 then we need to perform the conversion manually, because
10436 evaluate_subexp_standard doesn't do it. This conversion is
10437 necessary in Ada because the different kinds of float/fixed
10438 types in Ada have different representations.
10439
10440 Similarly, we need to perform the conversion from OP_LONG
10441 ourselves. */
edd079d9 10442 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10443 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10444
10445 return arg1;
4c4b4cd2
PH
10446
10447 case OP_STRING:
10448 {
76a01679 10449 struct value *result;
5b4ee69b 10450
76a01679
JB
10451 *pos -= 1;
10452 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10453 /* The result type will have code OP_STRING, bashed there from
10454 OP_ARRAY. Bash it back. */
df407dfe
AC
10455 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10456 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10457 return result;
4c4b4cd2 10458 }
14f9c5c9
AS
10459
10460 case UNOP_CAST:
10461 (*pos) += 2;
10462 type = exp->elts[pc + 1].type;
ced9779b 10463 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10464
4c4b4cd2
PH
10465 case UNOP_QUAL:
10466 (*pos) += 2;
10467 type = exp->elts[pc + 1].type;
10468 return ada_evaluate_subexp (type, exp, pos, noside);
10469
14f9c5c9
AS
10470 case BINOP_ASSIGN:
10471 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10472 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10473 {
10474 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10475 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10476 return arg1;
10477 return ada_value_assign (arg1, arg1);
10478 }
003f3813
JB
10479 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10480 except if the lhs of our assignment is a convenience variable.
10481 In the case of assigning to a convenience variable, the lhs
10482 should be exactly the result of the evaluation of the rhs. */
10483 type = value_type (arg1);
10484 if (VALUE_LVAL (arg1) == lval_internalvar)
10485 type = NULL;
10486 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10487 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10488 return arg1;
df407dfe
AC
10489 if (ada_is_fixed_point_type (value_type (arg1)))
10490 arg2 = cast_to_fixed (value_type (arg1), arg2);
10491 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10492 error
323e0a4a 10493 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10494 else
df407dfe 10495 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10496 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10497
10498 case BINOP_ADD:
10499 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10500 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10501 if (noside == EVAL_SKIP)
4c4b4cd2 10502 goto nosideret;
2ac8a782
JB
10503 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10504 return (value_from_longest
10505 (value_type (arg1),
10506 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10507 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10508 return (value_from_longest
10509 (value_type (arg2),
10510 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10511 if ((ada_is_fixed_point_type (value_type (arg1))
10512 || ada_is_fixed_point_type (value_type (arg2)))
10513 && value_type (arg1) != value_type (arg2))
323e0a4a 10514 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10515 /* Do the addition, and cast the result to the type of the first
10516 argument. We cannot cast the result to a reference type, so if
10517 ARG1 is a reference type, find its underlying type. */
10518 type = value_type (arg1);
10519 while (TYPE_CODE (type) == TYPE_CODE_REF)
10520 type = TYPE_TARGET_TYPE (type);
f44316fa 10521 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10522 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10523
10524 case BINOP_SUB:
10525 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10526 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10527 if (noside == EVAL_SKIP)
4c4b4cd2 10528 goto nosideret;
2ac8a782
JB
10529 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10530 return (value_from_longest
10531 (value_type (arg1),
10532 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10533 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10534 return (value_from_longest
10535 (value_type (arg2),
10536 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10537 if ((ada_is_fixed_point_type (value_type (arg1))
10538 || ada_is_fixed_point_type (value_type (arg2)))
10539 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10540 error (_("Operands of fixed-point subtraction "
10541 "must have the same type"));
b7789565
JB
10542 /* Do the substraction, and cast the result to the type of the first
10543 argument. We cannot cast the result to a reference type, so if
10544 ARG1 is a reference type, find its underlying type. */
10545 type = value_type (arg1);
10546 while (TYPE_CODE (type) == TYPE_CODE_REF)
10547 type = TYPE_TARGET_TYPE (type);
f44316fa 10548 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10549 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10550
10551 case BINOP_MUL:
10552 case BINOP_DIV:
e1578042
JB
10553 case BINOP_REM:
10554 case BINOP_MOD:
14f9c5c9
AS
10555 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10556 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10557 if (noside == EVAL_SKIP)
4c4b4cd2 10558 goto nosideret;
e1578042 10559 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10560 {
10561 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10562 return value_zero (value_type (arg1), not_lval);
10563 }
14f9c5c9 10564 else
4c4b4cd2 10565 {
a53b7a21 10566 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10567 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10568 arg1 = cast_from_fixed (type, arg1);
df407dfe 10569 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10570 arg2 = cast_from_fixed (type, arg2);
f44316fa 10571 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10572 return ada_value_binop (arg1, arg2, op);
10573 }
10574
4c4b4cd2
PH
10575 case BINOP_EQUAL:
10576 case BINOP_NOTEQUAL:
14f9c5c9 10577 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10578 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10579 if (noside == EVAL_SKIP)
76a01679 10580 goto nosideret;
4c4b4cd2 10581 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10582 tem = 0;
4c4b4cd2 10583 else
f44316fa
UW
10584 {
10585 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10586 tem = ada_value_equal (arg1, arg2);
10587 }
4c4b4cd2 10588 if (op == BINOP_NOTEQUAL)
76a01679 10589 tem = !tem;
fbb06eb1
UW
10590 type = language_bool_type (exp->language_defn, exp->gdbarch);
10591 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10592
10593 case UNOP_NEG:
10594 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10595 if (noside == EVAL_SKIP)
10596 goto nosideret;
df407dfe
AC
10597 else if (ada_is_fixed_point_type (value_type (arg1)))
10598 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10599 else
f44316fa
UW
10600 {
10601 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10602 return value_neg (arg1);
10603 }
4c4b4cd2 10604
2330c6c6
JB
10605 case BINOP_LOGICAL_AND:
10606 case BINOP_LOGICAL_OR:
10607 case UNOP_LOGICAL_NOT:
000d5124
JB
10608 {
10609 struct value *val;
10610
10611 *pos -= 1;
10612 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10613 type = language_bool_type (exp->language_defn, exp->gdbarch);
10614 return value_cast (type, val);
000d5124 10615 }
2330c6c6
JB
10616
10617 case BINOP_BITWISE_AND:
10618 case BINOP_BITWISE_IOR:
10619 case BINOP_BITWISE_XOR:
000d5124
JB
10620 {
10621 struct value *val;
10622
10623 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10624 *pos = pc;
10625 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10626
10627 return value_cast (value_type (arg1), val);
10628 }
2330c6c6 10629
14f9c5c9
AS
10630 case OP_VAR_VALUE:
10631 *pos -= 1;
6799def4 10632
14f9c5c9 10633 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10634 {
10635 *pos += 4;
10636 goto nosideret;
10637 }
da5c522f
JB
10638
10639 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10640 /* Only encountered when an unresolved symbol occurs in a
10641 context other than a function call, in which case, it is
52ce6436 10642 invalid. */
323e0a4a 10643 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10644 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10645
10646 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10647 {
0c1f74cf 10648 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10649 /* Check to see if this is a tagged type. We also need to handle
10650 the case where the type is a reference to a tagged type, but
10651 we have to be careful to exclude pointers to tagged types.
10652 The latter should be shown as usual (as a pointer), whereas
10653 a reference should mostly be transparent to the user. */
10654 if (ada_is_tagged_type (type, 0)
023db19c 10655 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10656 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10657 {
10658 /* Tagged types are a little special in the fact that the real
10659 type is dynamic and can only be determined by inspecting the
10660 object's tag. This means that we need to get the object's
10661 value first (EVAL_NORMAL) and then extract the actual object
10662 type from its tag.
10663
10664 Note that we cannot skip the final step where we extract
10665 the object type from its tag, because the EVAL_NORMAL phase
10666 results in dynamic components being resolved into fixed ones.
10667 This can cause problems when trying to print the type
10668 description of tagged types whose parent has a dynamic size:
10669 We use the type name of the "_parent" component in order
10670 to print the name of the ancestor type in the type description.
10671 If that component had a dynamic size, the resolution into
10672 a fixed type would result in the loss of that type name,
10673 thus preventing us from printing the name of the ancestor
10674 type in the type description. */
10675 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10676
10677 if (TYPE_CODE (type) != TYPE_CODE_REF)
10678 {
10679 struct type *actual_type;
10680
10681 actual_type = type_from_tag (ada_value_tag (arg1));
10682 if (actual_type == NULL)
10683 /* If, for some reason, we were unable to determine
10684 the actual type from the tag, then use the static
10685 approximation that we just computed as a fallback.
10686 This can happen if the debugging information is
10687 incomplete, for instance. */
10688 actual_type = type;
10689 return value_zero (actual_type, not_lval);
10690 }
10691 else
10692 {
10693 /* In the case of a ref, ada_coerce_ref takes care
10694 of determining the actual type. But the evaluation
10695 should return a ref as it should be valid to ask
10696 for its address; so rebuild a ref after coerce. */
10697 arg1 = ada_coerce_ref (arg1);
a65cfae5 10698 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10699 }
10700 }
0c1f74cf 10701
84754697
JB
10702 /* Records and unions for which GNAT encodings have been
10703 generated need to be statically fixed as well.
10704 Otherwise, non-static fixing produces a type where
10705 all dynamic properties are removed, which prevents "ptype"
10706 from being able to completely describe the type.
10707 For instance, a case statement in a variant record would be
10708 replaced by the relevant components based on the actual
10709 value of the discriminants. */
10710 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10711 && dynamic_template_type (type) != NULL)
10712 || (TYPE_CODE (type) == TYPE_CODE_UNION
10713 && ada_find_parallel_type (type, "___XVU") != NULL))
10714 {
10715 *pos += 4;
10716 return value_zero (to_static_fixed_type (type), not_lval);
10717 }
4c4b4cd2 10718 }
da5c522f
JB
10719
10720 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10721 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10722
10723 case OP_FUNCALL:
10724 (*pos) += 2;
10725
10726 /* Allocate arg vector, including space for the function to be
10727 called in argvec[0] and a terminating NULL. */
10728 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10729 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10730
10731 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10732 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10733 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10734 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10735 else
10736 {
10737 for (tem = 0; tem <= nargs; tem += 1)
10738 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10739 argvec[tem] = 0;
10740
10741 if (noside == EVAL_SKIP)
10742 goto nosideret;
10743 }
10744
ad82864c
JB
10745 if (ada_is_constrained_packed_array_type
10746 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10747 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10748 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10749 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10750 /* This is a packed array that has already been fixed, and
10751 therefore already coerced to a simple array. Nothing further
10752 to do. */
10753 ;
e6c2c623
PMR
10754 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10755 {
10756 /* Make sure we dereference references so that all the code below
10757 feels like it's really handling the referenced value. Wrapping
10758 types (for alignment) may be there, so make sure we strip them as
10759 well. */
10760 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10761 }
10762 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10763 && VALUE_LVAL (argvec[0]) == lval_memory)
10764 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10765
df407dfe 10766 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10767
10768 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10769 them. So, if this is an array typedef (encoding use for array
10770 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10771 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10772 type = ada_typedef_target_type (type);
10773
4c4b4cd2
PH
10774 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10775 {
61ee279c 10776 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10777 {
10778 case TYPE_CODE_FUNC:
61ee279c 10779 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10780 break;
10781 case TYPE_CODE_ARRAY:
10782 break;
10783 case TYPE_CODE_STRUCT:
10784 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10785 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10786 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10787 break;
10788 default:
323e0a4a 10789 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10790 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10791 break;
10792 }
10793 }
10794
10795 switch (TYPE_CODE (type))
10796 {
10797 case TYPE_CODE_FUNC:
10798 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10799 {
7022349d
PA
10800 if (TYPE_TARGET_TYPE (type) == NULL)
10801 error_call_unknown_return_type (NULL);
10802 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10803 }
e71585ff
PA
10804 return call_function_by_hand (argvec[0], NULL,
10805 gdb::make_array_view (argvec + 1,
10806 nargs));
c8ea1972
PH
10807 case TYPE_CODE_INTERNAL_FUNCTION:
10808 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10809 /* We don't know anything about what the internal
10810 function might return, but we have to return
10811 something. */
10812 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10813 not_lval);
10814 else
10815 return call_internal_function (exp->gdbarch, exp->language_defn,
10816 argvec[0], nargs, argvec + 1);
10817
4c4b4cd2
PH
10818 case TYPE_CODE_STRUCT:
10819 {
10820 int arity;
10821
4c4b4cd2
PH
10822 arity = ada_array_arity (type);
10823 type = ada_array_element_type (type, nargs);
10824 if (type == NULL)
323e0a4a 10825 error (_("cannot subscript or call a record"));
4c4b4cd2 10826 if (arity != nargs)
323e0a4a 10827 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10828 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10829 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10830 return
10831 unwrap_value (ada_value_subscript
10832 (argvec[0], nargs, argvec + 1));
10833 }
10834 case TYPE_CODE_ARRAY:
10835 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10836 {
10837 type = ada_array_element_type (type, nargs);
10838 if (type == NULL)
323e0a4a 10839 error (_("element type of array unknown"));
4c4b4cd2 10840 else
0a07e705 10841 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10842 }
10843 return
10844 unwrap_value (ada_value_subscript
10845 (ada_coerce_to_simple_array (argvec[0]),
10846 nargs, argvec + 1));
10847 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10848 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10849 {
deede10c 10850 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10851 type = ada_array_element_type (type, nargs);
10852 if (type == NULL)
323e0a4a 10853 error (_("element type of array unknown"));
4c4b4cd2 10854 else
0a07e705 10855 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10856 }
10857 return
deede10c
JB
10858 unwrap_value (ada_value_ptr_subscript (argvec[0],
10859 nargs, argvec + 1));
4c4b4cd2
PH
10860
10861 default:
e1d5a0d2
PH
10862 error (_("Attempt to index or call something other than an "
10863 "array or function"));
4c4b4cd2
PH
10864 }
10865
10866 case TERNOP_SLICE:
10867 {
10868 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10869 struct value *low_bound_val =
10870 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10871 struct value *high_bound_val =
10872 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10873 LONGEST low_bound;
10874 LONGEST high_bound;
5b4ee69b 10875
994b9211
AC
10876 low_bound_val = coerce_ref (low_bound_val);
10877 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
10878 low_bound = value_as_long (low_bound_val);
10879 high_bound = value_as_long (high_bound_val);
963a6417 10880
4c4b4cd2
PH
10881 if (noside == EVAL_SKIP)
10882 goto nosideret;
10883
4c4b4cd2
PH
10884 /* If this is a reference to an aligner type, then remove all
10885 the aligners. */
df407dfe
AC
10886 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10887 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10888 TYPE_TARGET_TYPE (value_type (array)) =
10889 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10890
ad82864c 10891 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10892 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10893
10894 /* If this is a reference to an array or an array lvalue,
10895 convert to a pointer. */
df407dfe
AC
10896 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10897 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10898 && VALUE_LVAL (array) == lval_memory))
10899 array = value_addr (array);
10900
1265e4aa 10901 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10902 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10903 (value_type (array))))
bff8c71f
TT
10904 return empty_array (ada_type_of_array (array, 0), low_bound,
10905 high_bound);
4c4b4cd2
PH
10906
10907 array = ada_coerce_to_simple_array_ptr (array);
10908
714e53ab
PH
10909 /* If we have more than one level of pointer indirection,
10910 dereference the value until we get only one level. */
df407dfe
AC
10911 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10912 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10913 == TYPE_CODE_PTR))
10914 array = value_ind (array);
10915
10916 /* Make sure we really do have an array type before going further,
10917 to avoid a SEGV when trying to get the index type or the target
10918 type later down the road if the debug info generated by
10919 the compiler is incorrect or incomplete. */
df407dfe 10920 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10921 error (_("cannot take slice of non-array"));
714e53ab 10922
828292f2
JB
10923 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10924 == TYPE_CODE_PTR)
4c4b4cd2 10925 {
828292f2
JB
10926 struct type *type0 = ada_check_typedef (value_type (array));
10927
0b5d8877 10928 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
bff8c71f 10929 return empty_array (TYPE_TARGET_TYPE (type0), low_bound, high_bound);
4c4b4cd2
PH
10930 else
10931 {
10932 struct type *arr_type0 =
828292f2 10933 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10934
f5938064
JG
10935 return ada_value_slice_from_ptr (array, arr_type0,
10936 longest_to_int (low_bound),
10937 longest_to_int (high_bound));
4c4b4cd2
PH
10938 }
10939 }
10940 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10941 return array;
10942 else if (high_bound < low_bound)
bff8c71f 10943 return empty_array (value_type (array), low_bound, high_bound);
4c4b4cd2 10944 else
529cad9c
PH
10945 return ada_value_slice (array, longest_to_int (low_bound),
10946 longest_to_int (high_bound));
4c4b4cd2 10947 }
14f9c5c9 10948
4c4b4cd2
PH
10949 case UNOP_IN_RANGE:
10950 (*pos) += 2;
10951 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10952 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10953
14f9c5c9 10954 if (noside == EVAL_SKIP)
4c4b4cd2 10955 goto nosideret;
14f9c5c9 10956
4c4b4cd2
PH
10957 switch (TYPE_CODE (type))
10958 {
10959 default:
e1d5a0d2
PH
10960 lim_warning (_("Membership test incompletely implemented; "
10961 "always returns true"));
fbb06eb1
UW
10962 type = language_bool_type (exp->language_defn, exp->gdbarch);
10963 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10964
10965 case TYPE_CODE_RANGE:
030b4912
UW
10966 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10967 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10968 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10969 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10970 type = language_bool_type (exp->language_defn, exp->gdbarch);
10971 return
10972 value_from_longest (type,
4c4b4cd2
PH
10973 (value_less (arg1, arg3)
10974 || value_equal (arg1, arg3))
10975 && (value_less (arg2, arg1)
10976 || value_equal (arg2, arg1)));
10977 }
10978
10979 case BINOP_IN_BOUNDS:
14f9c5c9 10980 (*pos) += 2;
4c4b4cd2
PH
10981 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10982 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10983
4c4b4cd2
PH
10984 if (noside == EVAL_SKIP)
10985 goto nosideret;
14f9c5c9 10986
4c4b4cd2 10987 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10988 {
10989 type = language_bool_type (exp->language_defn, exp->gdbarch);
10990 return value_zero (type, not_lval);
10991 }
14f9c5c9 10992
4c4b4cd2 10993 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10994
1eea4ebd
UW
10995 type = ada_index_type (value_type (arg2), tem, "range");
10996 if (!type)
10997 type = value_type (arg1);
14f9c5c9 10998
1eea4ebd
UW
10999 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11000 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11001
f44316fa
UW
11002 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11003 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11004 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11005 return
fbb06eb1 11006 value_from_longest (type,
4c4b4cd2
PH
11007 (value_less (arg1, arg3)
11008 || value_equal (arg1, arg3))
11009 && (value_less (arg2, arg1)
11010 || value_equal (arg2, arg1)));
11011
11012 case TERNOP_IN_RANGE:
11013 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11014 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11015 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11016
11017 if (noside == EVAL_SKIP)
11018 goto nosideret;
11019
f44316fa
UW
11020 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11021 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11022 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11023 return
fbb06eb1 11024 value_from_longest (type,
4c4b4cd2
PH
11025 (value_less (arg1, arg3)
11026 || value_equal (arg1, arg3))
11027 && (value_less (arg2, arg1)
11028 || value_equal (arg2, arg1)));
11029
11030 case OP_ATR_FIRST:
11031 case OP_ATR_LAST:
11032 case OP_ATR_LENGTH:
11033 {
76a01679 11034 struct type *type_arg;
5b4ee69b 11035
76a01679
JB
11036 if (exp->elts[*pos].opcode == OP_TYPE)
11037 {
11038 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11039 arg1 = NULL;
5bc23cb3 11040 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11041 }
11042 else
11043 {
11044 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11045 type_arg = NULL;
11046 }
11047
11048 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11049 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11050 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11051 *pos += 4;
11052
11053 if (noside == EVAL_SKIP)
11054 goto nosideret;
11055
11056 if (type_arg == NULL)
11057 {
11058 arg1 = ada_coerce_ref (arg1);
11059
ad82864c 11060 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11061 arg1 = ada_coerce_to_simple_array (arg1);
11062
aa4fb036 11063 if (op == OP_ATR_LENGTH)
1eea4ebd 11064 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11065 else
11066 {
11067 type = ada_index_type (value_type (arg1), tem,
11068 ada_attribute_name (op));
11069 if (type == NULL)
11070 type = builtin_type (exp->gdbarch)->builtin_int;
11071 }
76a01679
JB
11072
11073 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11074 return allocate_value (type);
76a01679
JB
11075
11076 switch (op)
11077 {
11078 default: /* Should never happen. */
323e0a4a 11079 error (_("unexpected attribute encountered"));
76a01679 11080 case OP_ATR_FIRST:
1eea4ebd
UW
11081 return value_from_longest
11082 (type, ada_array_bound (arg1, tem, 0));
76a01679 11083 case OP_ATR_LAST:
1eea4ebd
UW
11084 return value_from_longest
11085 (type, ada_array_bound (arg1, tem, 1));
76a01679 11086 case OP_ATR_LENGTH:
1eea4ebd
UW
11087 return value_from_longest
11088 (type, ada_array_length (arg1, tem));
76a01679
JB
11089 }
11090 }
11091 else if (discrete_type_p (type_arg))
11092 {
11093 struct type *range_type;
0d5cff50 11094 const char *name = ada_type_name (type_arg);
5b4ee69b 11095
76a01679
JB
11096 range_type = NULL;
11097 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11098 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11099 if (range_type == NULL)
11100 range_type = type_arg;
11101 switch (op)
11102 {
11103 default:
323e0a4a 11104 error (_("unexpected attribute encountered"));
76a01679 11105 case OP_ATR_FIRST:
690cc4eb 11106 return value_from_longest
43bbcdc2 11107 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11108 case OP_ATR_LAST:
690cc4eb 11109 return value_from_longest
43bbcdc2 11110 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11111 case OP_ATR_LENGTH:
323e0a4a 11112 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11113 }
11114 }
11115 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11116 error (_("unimplemented type attribute"));
76a01679
JB
11117 else
11118 {
11119 LONGEST low, high;
11120
ad82864c
JB
11121 if (ada_is_constrained_packed_array_type (type_arg))
11122 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11123
aa4fb036 11124 if (op == OP_ATR_LENGTH)
1eea4ebd 11125 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11126 else
11127 {
11128 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11129 if (type == NULL)
11130 type = builtin_type (exp->gdbarch)->builtin_int;
11131 }
1eea4ebd 11132
76a01679
JB
11133 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11134 return allocate_value (type);
11135
11136 switch (op)
11137 {
11138 default:
323e0a4a 11139 error (_("unexpected attribute encountered"));
76a01679 11140 case OP_ATR_FIRST:
1eea4ebd 11141 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11142 return value_from_longest (type, low);
11143 case OP_ATR_LAST:
1eea4ebd 11144 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11145 return value_from_longest (type, high);
11146 case OP_ATR_LENGTH:
1eea4ebd
UW
11147 low = ada_array_bound_from_type (type_arg, tem, 0);
11148 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11149 return value_from_longest (type, high - low + 1);
11150 }
11151 }
14f9c5c9
AS
11152 }
11153
4c4b4cd2
PH
11154 case OP_ATR_TAG:
11155 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11156 if (noside == EVAL_SKIP)
76a01679 11157 goto nosideret;
4c4b4cd2
PH
11158
11159 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11160 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11161
11162 return ada_value_tag (arg1);
11163
11164 case OP_ATR_MIN:
11165 case OP_ATR_MAX:
11166 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11167 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11168 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11169 if (noside == EVAL_SKIP)
76a01679 11170 goto nosideret;
d2e4a39e 11171 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11172 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11173 else
f44316fa
UW
11174 {
11175 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11176 return value_binop (arg1, arg2,
11177 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11178 }
14f9c5c9 11179
4c4b4cd2
PH
11180 case OP_ATR_MODULUS:
11181 {
31dedfee 11182 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11183
5b4ee69b 11184 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11185 if (noside == EVAL_SKIP)
11186 goto nosideret;
4c4b4cd2 11187
76a01679 11188 if (!ada_is_modular_type (type_arg))
323e0a4a 11189 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11190
76a01679
JB
11191 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11192 ada_modulus (type_arg));
4c4b4cd2
PH
11193 }
11194
11195
11196 case OP_ATR_POS:
11197 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11198 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11199 if (noside == EVAL_SKIP)
76a01679 11200 goto nosideret;
3cb382c9
UW
11201 type = builtin_type (exp->gdbarch)->builtin_int;
11202 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11203 return value_zero (type, not_lval);
14f9c5c9 11204 else
3cb382c9 11205 return value_pos_atr (type, arg1);
14f9c5c9 11206
4c4b4cd2
PH
11207 case OP_ATR_SIZE:
11208 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11209 type = value_type (arg1);
11210
11211 /* If the argument is a reference, then dereference its type, since
11212 the user is really asking for the size of the actual object,
11213 not the size of the pointer. */
11214 if (TYPE_CODE (type) == TYPE_CODE_REF)
11215 type = TYPE_TARGET_TYPE (type);
11216
4c4b4cd2 11217 if (noside == EVAL_SKIP)
76a01679 11218 goto nosideret;
4c4b4cd2 11219 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11220 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11221 else
22601c15 11222 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11223 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11224
11225 case OP_ATR_VAL:
11226 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11227 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11228 type = exp->elts[pc + 2].type;
14f9c5c9 11229 if (noside == EVAL_SKIP)
76a01679 11230 goto nosideret;
4c4b4cd2 11231 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11232 return value_zero (type, not_lval);
4c4b4cd2 11233 else
76a01679 11234 return value_val_atr (type, arg1);
4c4b4cd2
PH
11235
11236 case BINOP_EXP:
11237 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11238 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11239 if (noside == EVAL_SKIP)
11240 goto nosideret;
11241 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11242 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11243 else
f44316fa
UW
11244 {
11245 /* For integer exponentiation operations,
11246 only promote the first argument. */
11247 if (is_integral_type (value_type (arg2)))
11248 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11249 else
11250 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11251
11252 return value_binop (arg1, arg2, op);
11253 }
4c4b4cd2
PH
11254
11255 case UNOP_PLUS:
11256 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11257 if (noside == EVAL_SKIP)
11258 goto nosideret;
11259 else
11260 return arg1;
11261
11262 case UNOP_ABS:
11263 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11264 if (noside == EVAL_SKIP)
11265 goto nosideret;
f44316fa 11266 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11267 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11268 return value_neg (arg1);
14f9c5c9 11269 else
4c4b4cd2 11270 return arg1;
14f9c5c9
AS
11271
11272 case UNOP_IND:
5ec18f2b 11273 preeval_pos = *pos;
6b0d7253 11274 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11275 if (noside == EVAL_SKIP)
4c4b4cd2 11276 goto nosideret;
df407dfe 11277 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11278 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11279 {
11280 if (ada_is_array_descriptor_type (type))
11281 /* GDB allows dereferencing GNAT array descriptors. */
11282 {
11283 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11284
4c4b4cd2 11285 if (arrType == NULL)
323e0a4a 11286 error (_("Attempt to dereference null array pointer."));
00a4c844 11287 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11288 }
11289 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11290 || TYPE_CODE (type) == TYPE_CODE_REF
11291 /* In C you can dereference an array to get the 1st elt. */
11292 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11293 {
5ec18f2b
JG
11294 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11295 only be determined by inspecting the object's tag.
11296 This means that we need to evaluate completely the
11297 expression in order to get its type. */
11298
023db19c
JB
11299 if ((TYPE_CODE (type) == TYPE_CODE_REF
11300 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11301 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11302 {
11303 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11304 EVAL_NORMAL);
11305 type = value_type (ada_value_ind (arg1));
11306 }
11307 else
11308 {
11309 type = to_static_fixed_type
11310 (ada_aligned_type
11311 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11312 }
c1b5a1a6 11313 ada_ensure_varsize_limit (type);
714e53ab
PH
11314 return value_zero (type, lval_memory);
11315 }
4c4b4cd2 11316 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11317 {
11318 /* GDB allows dereferencing an int. */
11319 if (expect_type == NULL)
11320 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11321 lval_memory);
11322 else
11323 {
11324 expect_type =
11325 to_static_fixed_type (ada_aligned_type (expect_type));
11326 return value_zero (expect_type, lval_memory);
11327 }
11328 }
4c4b4cd2 11329 else
323e0a4a 11330 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11331 }
0963b4bd 11332 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11333 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11334
96967637
JB
11335 if (TYPE_CODE (type) == TYPE_CODE_INT)
11336 /* GDB allows dereferencing an int. If we were given
11337 the expect_type, then use that as the target type.
11338 Otherwise, assume that the target type is an int. */
11339 {
11340 if (expect_type != NULL)
11341 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11342 arg1));
11343 else
11344 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11345 (CORE_ADDR) value_as_address (arg1));
11346 }
6b0d7253 11347
4c4b4cd2
PH
11348 if (ada_is_array_descriptor_type (type))
11349 /* GDB allows dereferencing GNAT array descriptors. */
11350 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11351 else
4c4b4cd2 11352 return ada_value_ind (arg1);
14f9c5c9
AS
11353
11354 case STRUCTOP_STRUCT:
11355 tem = longest_to_int (exp->elts[pc + 1].longconst);
11356 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11357 preeval_pos = *pos;
14f9c5c9
AS
11358 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11359 if (noside == EVAL_SKIP)
4c4b4cd2 11360 goto nosideret;
14f9c5c9 11361 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11362 {
df407dfe 11363 struct type *type1 = value_type (arg1);
5b4ee69b 11364
76a01679
JB
11365 if (ada_is_tagged_type (type1, 1))
11366 {
11367 type = ada_lookup_struct_elt_type (type1,
11368 &exp->elts[pc + 2].string,
988f6b3d 11369 1, 1);
5ec18f2b
JG
11370
11371 /* If the field is not found, check if it exists in the
11372 extension of this object's type. This means that we
11373 need to evaluate completely the expression. */
11374
76a01679 11375 if (type == NULL)
5ec18f2b
JG
11376 {
11377 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11378 EVAL_NORMAL);
11379 arg1 = ada_value_struct_elt (arg1,
11380 &exp->elts[pc + 2].string,
11381 0);
11382 arg1 = unwrap_value (arg1);
11383 type = value_type (ada_to_fixed_value (arg1));
11384 }
76a01679
JB
11385 }
11386 else
11387 type =
11388 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11389 0);
76a01679
JB
11390
11391 return value_zero (ada_aligned_type (type), lval_memory);
11392 }
14f9c5c9 11393 else
a579cd9a
MW
11394 {
11395 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11396 arg1 = unwrap_value (arg1);
11397 return ada_to_fixed_value (arg1);
11398 }
284614f0 11399
14f9c5c9 11400 case OP_TYPE:
4c4b4cd2
PH
11401 /* The value is not supposed to be used. This is here to make it
11402 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11403 (*pos) += 2;
11404 if (noside == EVAL_SKIP)
4c4b4cd2 11405 goto nosideret;
14f9c5c9 11406 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11407 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11408 else
323e0a4a 11409 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11410
11411 case OP_AGGREGATE:
11412 case OP_CHOICES:
11413 case OP_OTHERS:
11414 case OP_DISCRETE_RANGE:
11415 case OP_POSITIONAL:
11416 case OP_NAME:
11417 if (noside == EVAL_NORMAL)
11418 switch (op)
11419 {
11420 case OP_NAME:
11421 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11422 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11423 case OP_AGGREGATE:
11424 error (_("Aggregates only allowed on the right of an assignment"));
11425 default:
0963b4bd
MS
11426 internal_error (__FILE__, __LINE__,
11427 _("aggregate apparently mangled"));
52ce6436
PH
11428 }
11429
11430 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11431 *pos += oplen - 1;
11432 for (tem = 0; tem < nargs; tem += 1)
11433 ada_evaluate_subexp (NULL, exp, pos, noside);
11434 goto nosideret;
14f9c5c9
AS
11435 }
11436
11437nosideret:
ced9779b 11438 return eval_skip_value (exp);
14f9c5c9 11439}
14f9c5c9 11440\f
d2e4a39e 11441
4c4b4cd2 11442 /* Fixed point */
14f9c5c9
AS
11443
11444/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11445 type name that encodes the 'small and 'delta information.
4c4b4cd2 11446 Otherwise, return NULL. */
14f9c5c9 11447
d2e4a39e 11448static const char *
ebf56fd3 11449fixed_type_info (struct type *type)
14f9c5c9 11450{
d2e4a39e 11451 const char *name = ada_type_name (type);
14f9c5c9
AS
11452 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11453
d2e4a39e
AS
11454 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11455 {
14f9c5c9 11456 const char *tail = strstr (name, "___XF_");
5b4ee69b 11457
14f9c5c9 11458 if (tail == NULL)
4c4b4cd2 11459 return NULL;
d2e4a39e 11460 else
4c4b4cd2 11461 return tail + 5;
14f9c5c9
AS
11462 }
11463 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11464 return fixed_type_info (TYPE_TARGET_TYPE (type));
11465 else
11466 return NULL;
11467}
11468
4c4b4cd2 11469/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11470
11471int
ebf56fd3 11472ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11473{
11474 return fixed_type_info (type) != NULL;
11475}
11476
4c4b4cd2
PH
11477/* Return non-zero iff TYPE represents a System.Address type. */
11478
11479int
11480ada_is_system_address_type (struct type *type)
11481{
11482 return (TYPE_NAME (type)
11483 && strcmp (TYPE_NAME (type), "system__address") == 0);
11484}
11485
14f9c5c9 11486/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11487 type, return the target floating-point type to be used to represent
11488 of this type during internal computation. */
11489
11490static struct type *
11491ada_scaling_type (struct type *type)
11492{
11493 return builtin_type (get_type_arch (type))->builtin_long_double;
11494}
11495
11496/* Assuming that TYPE is the representation of an Ada fixed-point
11497 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11498 delta cannot be determined. */
14f9c5c9 11499
50eff16b 11500struct value *
ebf56fd3 11501ada_delta (struct type *type)
14f9c5c9
AS
11502{
11503 const char *encoding = fixed_type_info (type);
50eff16b
UW
11504 struct type *scale_type = ada_scaling_type (type);
11505
11506 long long num, den;
11507
11508 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11509 return nullptr;
d2e4a39e 11510 else
50eff16b
UW
11511 return value_binop (value_from_longest (scale_type, num),
11512 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11513}
11514
11515/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11516 factor ('SMALL value) associated with the type. */
14f9c5c9 11517
50eff16b
UW
11518struct value *
11519ada_scaling_factor (struct type *type)
14f9c5c9
AS
11520{
11521 const char *encoding = fixed_type_info (type);
50eff16b
UW
11522 struct type *scale_type = ada_scaling_type (type);
11523
11524 long long num0, den0, num1, den1;
14f9c5c9 11525 int n;
d2e4a39e 11526
50eff16b 11527 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11528 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11529
11530 if (n < 2)
50eff16b 11531 return value_from_longest (scale_type, 1);
14f9c5c9 11532 else if (n == 4)
50eff16b
UW
11533 return value_binop (value_from_longest (scale_type, num1),
11534 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11535 else
50eff16b
UW
11536 return value_binop (value_from_longest (scale_type, num0),
11537 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11538}
11539
14f9c5c9 11540\f
d2e4a39e 11541
4c4b4cd2 11542 /* Range types */
14f9c5c9
AS
11543
11544/* Scan STR beginning at position K for a discriminant name, and
11545 return the value of that discriminant field of DVAL in *PX. If
11546 PNEW_K is not null, put the position of the character beyond the
11547 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11548 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11549
11550static int
108d56a4 11551scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11552 int *pnew_k)
14f9c5c9
AS
11553{
11554 static char *bound_buffer = NULL;
11555 static size_t bound_buffer_len = 0;
5da1a4d3 11556 const char *pstart, *pend, *bound;
d2e4a39e 11557 struct value *bound_val;
14f9c5c9
AS
11558
11559 if (dval == NULL || str == NULL || str[k] == '\0')
11560 return 0;
11561
5da1a4d3
SM
11562 pstart = str + k;
11563 pend = strstr (pstart, "__");
14f9c5c9
AS
11564 if (pend == NULL)
11565 {
5da1a4d3 11566 bound = pstart;
14f9c5c9
AS
11567 k += strlen (bound);
11568 }
d2e4a39e 11569 else
14f9c5c9 11570 {
5da1a4d3
SM
11571 int len = pend - pstart;
11572
11573 /* Strip __ and beyond. */
11574 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11575 strncpy (bound_buffer, pstart, len);
11576 bound_buffer[len] = '\0';
11577
14f9c5c9 11578 bound = bound_buffer;
d2e4a39e 11579 k = pend - str;
14f9c5c9 11580 }
d2e4a39e 11581
df407dfe 11582 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11583 if (bound_val == NULL)
11584 return 0;
11585
11586 *px = value_as_long (bound_val);
11587 if (pnew_k != NULL)
11588 *pnew_k = k;
11589 return 1;
11590}
11591
11592/* Value of variable named NAME in the current environment. If
11593 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11594 otherwise causes an error with message ERR_MSG. */
11595
d2e4a39e 11596static struct value *
edb0c9cb 11597get_var_value (const char *name, const char *err_msg)
14f9c5c9 11598{
b5ec771e 11599 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11600
54d343a2 11601 std::vector<struct block_symbol> syms;
b5ec771e
PA
11602 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11603 get_selected_block (0),
11604 VAR_DOMAIN, &syms, 1);
14f9c5c9
AS
11605
11606 if (nsyms != 1)
11607 {
11608 if (err_msg == NULL)
4c4b4cd2 11609 return 0;
14f9c5c9 11610 else
8a3fe4f8 11611 error (("%s"), err_msg);
14f9c5c9
AS
11612 }
11613
54d343a2 11614 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11615}
d2e4a39e 11616
edb0c9cb
PA
11617/* Value of integer variable named NAME in the current environment.
11618 If no such variable is found, returns false. Otherwise, sets VALUE
11619 to the variable's value and returns true. */
4c4b4cd2 11620
edb0c9cb
PA
11621bool
11622get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11623{
4c4b4cd2 11624 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11625
14f9c5c9 11626 if (var_val == 0)
edb0c9cb
PA
11627 return false;
11628
11629 value = value_as_long (var_val);
11630 return true;
14f9c5c9 11631}
d2e4a39e 11632
14f9c5c9
AS
11633
11634/* Return a range type whose base type is that of the range type named
11635 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11636 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11637 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11638 corresponding range type from debug information; fall back to using it
11639 if symbol lookup fails. If a new type must be created, allocate it
11640 like ORIG_TYPE was. The bounds information, in general, is encoded
11641 in NAME, the base type given in the named range type. */
14f9c5c9 11642
d2e4a39e 11643static struct type *
28c85d6c 11644to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11645{
0d5cff50 11646 const char *name;
14f9c5c9 11647 struct type *base_type;
108d56a4 11648 const char *subtype_info;
14f9c5c9 11649
28c85d6c
JB
11650 gdb_assert (raw_type != NULL);
11651 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11652
1ce677a4 11653 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11654 base_type = TYPE_TARGET_TYPE (raw_type);
11655 else
11656 base_type = raw_type;
11657
28c85d6c 11658 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11659 subtype_info = strstr (name, "___XD");
11660 if (subtype_info == NULL)
690cc4eb 11661 {
43bbcdc2
PH
11662 LONGEST L = ada_discrete_type_low_bound (raw_type);
11663 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11664
690cc4eb
PH
11665 if (L < INT_MIN || U > INT_MAX)
11666 return raw_type;
11667 else
0c9c3474
SA
11668 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11669 L, U);
690cc4eb 11670 }
14f9c5c9
AS
11671 else
11672 {
11673 static char *name_buf = NULL;
11674 static size_t name_len = 0;
11675 int prefix_len = subtype_info - name;
11676 LONGEST L, U;
11677 struct type *type;
108d56a4 11678 const char *bounds_str;
14f9c5c9
AS
11679 int n;
11680
11681 GROW_VECT (name_buf, name_len, prefix_len + 5);
11682 strncpy (name_buf, name, prefix_len);
11683 name_buf[prefix_len] = '\0';
11684
11685 subtype_info += 5;
11686 bounds_str = strchr (subtype_info, '_');
11687 n = 1;
11688
d2e4a39e 11689 if (*subtype_info == 'L')
4c4b4cd2
PH
11690 {
11691 if (!ada_scan_number (bounds_str, n, &L, &n)
11692 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11693 return raw_type;
11694 if (bounds_str[n] == '_')
11695 n += 2;
0963b4bd 11696 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11697 n += 1;
11698 subtype_info += 1;
11699 }
d2e4a39e 11700 else
4c4b4cd2 11701 {
4c4b4cd2 11702 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11703 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11704 {
323e0a4a 11705 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11706 L = 1;
11707 }
11708 }
14f9c5c9 11709
d2e4a39e 11710 if (*subtype_info == 'U')
4c4b4cd2
PH
11711 {
11712 if (!ada_scan_number (bounds_str, n, &U, &n)
11713 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11714 return raw_type;
11715 }
d2e4a39e 11716 else
4c4b4cd2 11717 {
4c4b4cd2 11718 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11719 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11720 {
323e0a4a 11721 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11722 U = L;
11723 }
11724 }
14f9c5c9 11725
0c9c3474
SA
11726 type = create_static_range_type (alloc_type_copy (raw_type),
11727 base_type, L, U);
f5a91472
JB
11728 /* create_static_range_type alters the resulting type's length
11729 to match the size of the base_type, which is not what we want.
11730 Set it back to the original range type's length. */
11731 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11732 TYPE_NAME (type) = name;
14f9c5c9
AS
11733 return type;
11734 }
11735}
11736
4c4b4cd2
PH
11737/* True iff NAME is the name of a range type. */
11738
14f9c5c9 11739int
d2e4a39e 11740ada_is_range_type_name (const char *name)
14f9c5c9
AS
11741{
11742 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11743}
14f9c5c9 11744\f
d2e4a39e 11745
4c4b4cd2
PH
11746 /* Modular types */
11747
11748/* True iff TYPE is an Ada modular type. */
14f9c5c9 11749
14f9c5c9 11750int
d2e4a39e 11751ada_is_modular_type (struct type *type)
14f9c5c9 11752{
18af8284 11753 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11754
11755 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11756 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11757 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11758}
11759
4c4b4cd2
PH
11760/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11761
61ee279c 11762ULONGEST
0056e4d5 11763ada_modulus (struct type *type)
14f9c5c9 11764{
43bbcdc2 11765 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11766}
d2e4a39e 11767\f
f7f9143b
JB
11768
11769/* Ada exception catchpoint support:
11770 ---------------------------------
11771
11772 We support 3 kinds of exception catchpoints:
11773 . catchpoints on Ada exceptions
11774 . catchpoints on unhandled Ada exceptions
11775 . catchpoints on failed assertions
11776
11777 Exceptions raised during failed assertions, or unhandled exceptions
11778 could perfectly be caught with the general catchpoint on Ada exceptions.
11779 However, we can easily differentiate these two special cases, and having
11780 the option to distinguish these two cases from the rest can be useful
11781 to zero-in on certain situations.
11782
11783 Exception catchpoints are a specialized form of breakpoint,
11784 since they rely on inserting breakpoints inside known routines
11785 of the GNAT runtime. The implementation therefore uses a standard
11786 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11787 of breakpoint_ops.
11788
0259addd
JB
11789 Support in the runtime for exception catchpoints have been changed
11790 a few times already, and these changes affect the implementation
11791 of these catchpoints. In order to be able to support several
11792 variants of the runtime, we use a sniffer that will determine
28010a5d 11793 the runtime variant used by the program being debugged. */
f7f9143b 11794
82eacd52
JB
11795/* Ada's standard exceptions.
11796
11797 The Ada 83 standard also defined Numeric_Error. But there so many
11798 situations where it was unclear from the Ada 83 Reference Manual
11799 (RM) whether Constraint_Error or Numeric_Error should be raised,
11800 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11801 Interpretation saying that anytime the RM says that Numeric_Error
11802 should be raised, the implementation may raise Constraint_Error.
11803 Ada 95 went one step further and pretty much removed Numeric_Error
11804 from the list of standard exceptions (it made it a renaming of
11805 Constraint_Error, to help preserve compatibility when compiling
11806 an Ada83 compiler). As such, we do not include Numeric_Error from
11807 this list of standard exceptions. */
3d0b0fa3 11808
a121b7c1 11809static const char *standard_exc[] = {
3d0b0fa3
JB
11810 "constraint_error",
11811 "program_error",
11812 "storage_error",
11813 "tasking_error"
11814};
11815
0259addd
JB
11816typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11817
11818/* A structure that describes how to support exception catchpoints
11819 for a given executable. */
11820
11821struct exception_support_info
11822{
11823 /* The name of the symbol to break on in order to insert
11824 a catchpoint on exceptions. */
11825 const char *catch_exception_sym;
11826
11827 /* The name of the symbol to break on in order to insert
11828 a catchpoint on unhandled exceptions. */
11829 const char *catch_exception_unhandled_sym;
11830
11831 /* The name of the symbol to break on in order to insert
11832 a catchpoint on failed assertions. */
11833 const char *catch_assert_sym;
11834
9f757bf7
XR
11835 /* The name of the symbol to break on in order to insert
11836 a catchpoint on exception handling. */
11837 const char *catch_handlers_sym;
11838
0259addd
JB
11839 /* Assuming that the inferior just triggered an unhandled exception
11840 catchpoint, this function is responsible for returning the address
11841 in inferior memory where the name of that exception is stored.
11842 Return zero if the address could not be computed. */
11843 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11844};
11845
11846static CORE_ADDR ada_unhandled_exception_name_addr (void);
11847static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11848
11849/* The following exception support info structure describes how to
11850 implement exception catchpoints with the latest version of the
11851 Ada runtime (as of 2007-03-06). */
11852
11853static const struct exception_support_info default_exception_support_info =
11854{
11855 "__gnat_debug_raise_exception", /* catch_exception_sym */
11856 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11857 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 11858 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
11859 ada_unhandled_exception_name_addr
11860};
11861
11862/* The following exception support info structure describes how to
11863 implement exception catchpoints with a slightly older version
11864 of the Ada runtime. */
11865
11866static const struct exception_support_info exception_support_info_fallback =
11867{
11868 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11869 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11870 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 11871 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
11872 ada_unhandled_exception_name_addr_from_raise
11873};
11874
f17011e0
JB
11875/* Return nonzero if we can detect the exception support routines
11876 described in EINFO.
11877
11878 This function errors out if an abnormal situation is detected
11879 (for instance, if we find the exception support routines, but
11880 that support is found to be incomplete). */
11881
11882static int
11883ada_has_this_exception_support (const struct exception_support_info *einfo)
11884{
11885 struct symbol *sym;
11886
11887 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11888 that should be compiled with debugging information. As a result, we
11889 expect to find that symbol in the symtabs. */
11890
11891 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11892 if (sym == NULL)
a6af7abe
JB
11893 {
11894 /* Perhaps we did not find our symbol because the Ada runtime was
11895 compiled without debugging info, or simply stripped of it.
11896 It happens on some GNU/Linux distributions for instance, where
11897 users have to install a separate debug package in order to get
11898 the runtime's debugging info. In that situation, let the user
11899 know why we cannot insert an Ada exception catchpoint.
11900
11901 Note: Just for the purpose of inserting our Ada exception
11902 catchpoint, we could rely purely on the associated minimal symbol.
11903 But we would be operating in degraded mode anyway, since we are
11904 still lacking the debugging info needed later on to extract
11905 the name of the exception being raised (this name is printed in
11906 the catchpoint message, and is also used when trying to catch
11907 a specific exception). We do not handle this case for now. */
3b7344d5 11908 struct bound_minimal_symbol msym
1c8e84b0
JB
11909 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11910
3b7344d5 11911 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11912 error (_("Your Ada runtime appears to be missing some debugging "
11913 "information.\nCannot insert Ada exception catchpoint "
11914 "in this configuration."));
11915
11916 return 0;
11917 }
f17011e0
JB
11918
11919 /* Make sure that the symbol we found corresponds to a function. */
11920
11921 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11922 error (_("Symbol \"%s\" is not a function (class = %d)"),
11923 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11924
11925 return 1;
11926}
11927
0259addd
JB
11928/* Inspect the Ada runtime and determine which exception info structure
11929 should be used to provide support for exception catchpoints.
11930
3eecfa55
JB
11931 This function will always set the per-inferior exception_info,
11932 or raise an error. */
0259addd
JB
11933
11934static void
11935ada_exception_support_info_sniffer (void)
11936{
3eecfa55 11937 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11938
11939 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11940 if (data->exception_info != NULL)
0259addd
JB
11941 return;
11942
11943 /* Check the latest (default) exception support info. */
f17011e0 11944 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11945 {
3eecfa55 11946 data->exception_info = &default_exception_support_info;
0259addd
JB
11947 return;
11948 }
11949
11950 /* Try our fallback exception suport info. */
f17011e0 11951 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11952 {
3eecfa55 11953 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11954 return;
11955 }
11956
11957 /* Sometimes, it is normal for us to not be able to find the routine
11958 we are looking for. This happens when the program is linked with
11959 the shared version of the GNAT runtime, and the program has not been
11960 started yet. Inform the user of these two possible causes if
11961 applicable. */
11962
ccefe4c4 11963 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11964 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11965
11966 /* If the symbol does not exist, then check that the program is
11967 already started, to make sure that shared libraries have been
11968 loaded. If it is not started, this may mean that the symbol is
11969 in a shared library. */
11970
e99b03dc 11971 if (inferior_ptid.pid () == 0)
0259addd
JB
11972 error (_("Unable to insert catchpoint. Try to start the program first."));
11973
11974 /* At this point, we know that we are debugging an Ada program and
11975 that the inferior has been started, but we still are not able to
0963b4bd 11976 find the run-time symbols. That can mean that we are in
0259addd
JB
11977 configurable run time mode, or that a-except as been optimized
11978 out by the linker... In any case, at this point it is not worth
11979 supporting this feature. */
11980
7dda8cff 11981 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11982}
11983
f7f9143b
JB
11984/* True iff FRAME is very likely to be that of a function that is
11985 part of the runtime system. This is all very heuristic, but is
11986 intended to be used as advice as to what frames are uninteresting
11987 to most users. */
11988
11989static int
11990is_known_support_routine (struct frame_info *frame)
11991{
692465f1 11992 enum language func_lang;
f7f9143b 11993 int i;
f35a17b5 11994 const char *fullname;
f7f9143b 11995
4ed6b5be
JB
11996 /* If this code does not have any debugging information (no symtab),
11997 This cannot be any user code. */
f7f9143b 11998
51abb421 11999 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12000 if (sal.symtab == NULL)
12001 return 1;
12002
4ed6b5be
JB
12003 /* If there is a symtab, but the associated source file cannot be
12004 located, then assume this is not user code: Selecting a frame
12005 for which we cannot display the code would not be very helpful
12006 for the user. This should also take care of case such as VxWorks
12007 where the kernel has some debugging info provided for a few units. */
f7f9143b 12008
f35a17b5
JK
12009 fullname = symtab_to_fullname (sal.symtab);
12010 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12011 return 1;
12012
4ed6b5be
JB
12013 /* Check the unit filename againt the Ada runtime file naming.
12014 We also check the name of the objfile against the name of some
12015 known system libraries that sometimes come with debugging info
12016 too. */
12017
f7f9143b
JB
12018 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12019 {
12020 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12021 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12022 return 1;
eb822aa6
DE
12023 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12024 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12025 return 1;
f7f9143b
JB
12026 }
12027
4ed6b5be 12028 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12029
c6dc63a1
TT
12030 gdb::unique_xmalloc_ptr<char> func_name
12031 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12032 if (func_name == NULL)
12033 return 1;
12034
12035 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12036 {
12037 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12038 if (re_exec (func_name.get ()))
12039 return 1;
f7f9143b
JB
12040 }
12041
12042 return 0;
12043}
12044
12045/* Find the first frame that contains debugging information and that is not
12046 part of the Ada run-time, starting from FI and moving upward. */
12047
0ef643c8 12048void
f7f9143b
JB
12049ada_find_printable_frame (struct frame_info *fi)
12050{
12051 for (; fi != NULL; fi = get_prev_frame (fi))
12052 {
12053 if (!is_known_support_routine (fi))
12054 {
12055 select_frame (fi);
12056 break;
12057 }
12058 }
12059
12060}
12061
12062/* Assuming that the inferior just triggered an unhandled exception
12063 catchpoint, return the address in inferior memory where the name
12064 of the exception is stored.
12065
12066 Return zero if the address could not be computed. */
12067
12068static CORE_ADDR
12069ada_unhandled_exception_name_addr (void)
0259addd
JB
12070{
12071 return parse_and_eval_address ("e.full_name");
12072}
12073
12074/* Same as ada_unhandled_exception_name_addr, except that this function
12075 should be used when the inferior uses an older version of the runtime,
12076 where the exception name needs to be extracted from a specific frame
12077 several frames up in the callstack. */
12078
12079static CORE_ADDR
12080ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12081{
12082 int frame_level;
12083 struct frame_info *fi;
3eecfa55 12084 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12085
12086 /* To determine the name of this exception, we need to select
12087 the frame corresponding to RAISE_SYM_NAME. This frame is
12088 at least 3 levels up, so we simply skip the first 3 frames
12089 without checking the name of their associated function. */
12090 fi = get_current_frame ();
12091 for (frame_level = 0; frame_level < 3; frame_level += 1)
12092 if (fi != NULL)
12093 fi = get_prev_frame (fi);
12094
12095 while (fi != NULL)
12096 {
692465f1
JB
12097 enum language func_lang;
12098
c6dc63a1
TT
12099 gdb::unique_xmalloc_ptr<char> func_name
12100 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12101 if (func_name != NULL)
12102 {
c6dc63a1 12103 if (strcmp (func_name.get (),
55b87a52
KS
12104 data->exception_info->catch_exception_sym) == 0)
12105 break; /* We found the frame we were looking for... */
55b87a52 12106 }
fb44b1a7 12107 fi = get_prev_frame (fi);
f7f9143b
JB
12108 }
12109
12110 if (fi == NULL)
12111 return 0;
12112
12113 select_frame (fi);
12114 return parse_and_eval_address ("id.full_name");
12115}
12116
12117/* Assuming the inferior just triggered an Ada exception catchpoint
12118 (of any type), return the address in inferior memory where the name
12119 of the exception is stored, if applicable.
12120
45db7c09
PA
12121 Assumes the selected frame is the current frame.
12122
f7f9143b
JB
12123 Return zero if the address could not be computed, or if not relevant. */
12124
12125static CORE_ADDR
761269c8 12126ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12127 struct breakpoint *b)
12128{
3eecfa55
JB
12129 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12130
f7f9143b
JB
12131 switch (ex)
12132 {
761269c8 12133 case ada_catch_exception:
f7f9143b
JB
12134 return (parse_and_eval_address ("e.full_name"));
12135 break;
12136
761269c8 12137 case ada_catch_exception_unhandled:
3eecfa55 12138 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12139 break;
9f757bf7
XR
12140
12141 case ada_catch_handlers:
12142 return 0; /* The runtimes does not provide access to the exception
12143 name. */
12144 break;
12145
761269c8 12146 case ada_catch_assert:
f7f9143b
JB
12147 return 0; /* Exception name is not relevant in this case. */
12148 break;
12149
12150 default:
12151 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12152 break;
12153 }
12154
12155 return 0; /* Should never be reached. */
12156}
12157
e547c119
JB
12158/* Assuming the inferior is stopped at an exception catchpoint,
12159 return the message which was associated to the exception, if
12160 available. Return NULL if the message could not be retrieved.
12161
e547c119
JB
12162 Note: The exception message can be associated to an exception
12163 either through the use of the Raise_Exception function, or
12164 more simply (Ada 2005 and later), via:
12165
12166 raise Exception_Name with "exception message";
12167
12168 */
12169
6f46ac85 12170static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12171ada_exception_message_1 (void)
12172{
12173 struct value *e_msg_val;
e547c119 12174 int e_msg_len;
e547c119
JB
12175
12176 /* For runtimes that support this feature, the exception message
12177 is passed as an unbounded string argument called "message". */
12178 e_msg_val = parse_and_eval ("message");
12179 if (e_msg_val == NULL)
12180 return NULL; /* Exception message not supported. */
12181
12182 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12183 gdb_assert (e_msg_val != NULL);
12184 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12185
12186 /* If the message string is empty, then treat it as if there was
12187 no exception message. */
12188 if (e_msg_len <= 0)
12189 return NULL;
12190
6f46ac85
TT
12191 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12192 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12193 e_msg.get ()[e_msg_len] = '\0';
e547c119 12194
e547c119
JB
12195 return e_msg;
12196}
12197
12198/* Same as ada_exception_message_1, except that all exceptions are
12199 contained here (returning NULL instead). */
12200
6f46ac85 12201static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12202ada_exception_message (void)
12203{
6f46ac85 12204 gdb::unique_xmalloc_ptr<char> e_msg;
e547c119 12205
a70b8144 12206 try
e547c119
JB
12207 {
12208 e_msg = ada_exception_message_1 ();
12209 }
230d2906 12210 catch (const gdb_exception_error &e)
e547c119 12211 {
6f46ac85 12212 e_msg.reset (nullptr);
e547c119 12213 }
e547c119
JB
12214
12215 return e_msg;
12216}
12217
f7f9143b
JB
12218/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12219 any error that ada_exception_name_addr_1 might cause to be thrown.
12220 When an error is intercepted, a warning with the error message is printed,
12221 and zero is returned. */
12222
12223static CORE_ADDR
761269c8 12224ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12225 struct breakpoint *b)
12226{
f7f9143b
JB
12227 CORE_ADDR result = 0;
12228
a70b8144 12229 try
f7f9143b
JB
12230 {
12231 result = ada_exception_name_addr_1 (ex, b);
12232 }
12233
230d2906 12234 catch (const gdb_exception_error &e)
f7f9143b 12235 {
3d6e9d23 12236 warning (_("failed to get exception name: %s"), e.what ());
f7f9143b
JB
12237 return 0;
12238 }
12239
12240 return result;
12241}
12242
cb7de75e 12243static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12244 (const char *excep_string,
12245 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12246
12247/* Ada catchpoints.
12248
12249 In the case of catchpoints on Ada exceptions, the catchpoint will
12250 stop the target on every exception the program throws. When a user
12251 specifies the name of a specific exception, we translate this
12252 request into a condition expression (in text form), and then parse
12253 it into an expression stored in each of the catchpoint's locations.
12254 We then use this condition to check whether the exception that was
12255 raised is the one the user is interested in. If not, then the
12256 target is resumed again. We store the name of the requested
12257 exception, in order to be able to re-set the condition expression
12258 when symbols change. */
12259
12260/* An instance of this type is used to represent an Ada catchpoint
5625a286 12261 breakpoint location. */
28010a5d 12262
5625a286 12263class ada_catchpoint_location : public bp_location
28010a5d 12264{
5625a286 12265public:
5f486660
TT
12266 ada_catchpoint_location (breakpoint *owner)
12267 : bp_location (owner)
5625a286 12268 {}
28010a5d
PA
12269
12270 /* The condition that checks whether the exception that was raised
12271 is the specific exception the user specified on catchpoint
12272 creation. */
4d01a485 12273 expression_up excep_cond_expr;
28010a5d
PA
12274};
12275
c1fc2657 12276/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12277
c1fc2657 12278struct ada_catchpoint : public breakpoint
28010a5d 12279{
28010a5d 12280 /* The name of the specific exception the user specified. */
bc18fbb5 12281 std::string excep_string;
28010a5d
PA
12282};
12283
12284/* Parse the exception condition string in the context of each of the
12285 catchpoint's locations, and store them for later evaluation. */
12286
12287static void
9f757bf7
XR
12288create_excep_cond_exprs (struct ada_catchpoint *c,
12289 enum ada_exception_catchpoint_kind ex)
28010a5d 12290{
28010a5d 12291 /* Nothing to do if there's no specific exception to catch. */
bc18fbb5 12292 if (c->excep_string.empty ())
28010a5d
PA
12293 return;
12294
12295 /* Same if there are no locations... */
c1fc2657 12296 if (c->loc == NULL)
28010a5d
PA
12297 return;
12298
2ff0a947
TT
12299 /* We have to compute the expression once for each program space,
12300 because the expression may hold the addresses of multiple symbols
12301 in some cases. */
12302 std::multimap<program_space *, struct bp_location *> loc_map;
bde09ab7 12303 for (bp_location *bl = c->loc; bl != NULL; bl = bl->next)
2ff0a947 12304 loc_map.emplace (bl->pspace, bl);
28010a5d 12305
2ff0a947
TT
12306 scoped_restore_current_program_space save_pspace;
12307
12308 std::string cond_string;
12309 program_space *last_ps = nullptr;
12310 for (auto iter : loc_map)
28010a5d
PA
12311 {
12312 struct ada_catchpoint_location *ada_loc
2ff0a947
TT
12313 = (struct ada_catchpoint_location *) iter.second;
12314
12315 if (ada_loc->pspace != last_ps)
12316 {
12317 last_ps = ada_loc->pspace;
12318 set_current_program_space (last_ps);
12319
12320 /* Compute the condition expression in text form, from the
12321 specific expection we want to catch. */
12322 cond_string
12323 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (),
12324 ex);
12325 }
12326
4d01a485 12327 expression_up exp;
28010a5d 12328
2ff0a947 12329 if (!ada_loc->shlib_disabled)
28010a5d 12330 {
bbc13ae3 12331 const char *s;
28010a5d 12332
cb7de75e 12333 s = cond_string.c_str ();
a70b8144 12334 try
28010a5d 12335 {
2ff0a947
TT
12336 exp = parse_exp_1 (&s, ada_loc->address,
12337 block_for_pc (ada_loc->address),
036e657b 12338 0);
28010a5d 12339 }
230d2906 12340 catch (const gdb_exception_error &e)
849f2b52
JB
12341 {
12342 warning (_("failed to reevaluate internal exception condition "
12343 "for catchpoint %d: %s"),
3d6e9d23 12344 c->number, e.what ());
849f2b52 12345 }
28010a5d
PA
12346 }
12347
b22e99fd 12348 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12349 }
28010a5d
PA
12350}
12351
28010a5d
PA
12352/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12353 structure for all exception catchpoint kinds. */
12354
12355static struct bp_location *
761269c8 12356allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12357 struct breakpoint *self)
12358{
5f486660 12359 return new ada_catchpoint_location (self);
28010a5d
PA
12360}
12361
12362/* Implement the RE_SET method in the breakpoint_ops structure for all
12363 exception catchpoint kinds. */
12364
12365static void
761269c8 12366re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12367{
12368 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12369
12370 /* Call the base class's method. This updates the catchpoint's
12371 locations. */
2060206e 12372 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12373
12374 /* Reparse the exception conditional expressions. One for each
12375 location. */
9f757bf7 12376 create_excep_cond_exprs (c, ex);
28010a5d
PA
12377}
12378
12379/* Returns true if we should stop for this breakpoint hit. If the
12380 user specified a specific exception, we only want to cause a stop
12381 if the program thrown that exception. */
12382
12383static int
12384should_stop_exception (const struct bp_location *bl)
12385{
12386 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12387 const struct ada_catchpoint_location *ada_loc
12388 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12389 int stop;
12390
12391 /* With no specific exception, should always stop. */
bc18fbb5 12392 if (c->excep_string.empty ())
28010a5d
PA
12393 return 1;
12394
12395 if (ada_loc->excep_cond_expr == NULL)
12396 {
12397 /* We will have a NULL expression if back when we were creating
12398 the expressions, this location's had failed to parse. */
12399 return 1;
12400 }
12401
12402 stop = 1;
a70b8144 12403 try
28010a5d
PA
12404 {
12405 struct value *mark;
12406
12407 mark = value_mark ();
4d01a485 12408 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12409 value_free_to_mark (mark);
12410 }
230d2906 12411 catch (const gdb_exception &ex)
492d29ea
PA
12412 {
12413 exception_fprintf (gdb_stderr, ex,
12414 _("Error in testing exception condition:\n"));
12415 }
492d29ea 12416
28010a5d
PA
12417 return stop;
12418}
12419
12420/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12421 for all exception catchpoint kinds. */
12422
12423static void
761269c8 12424check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12425{
12426 bs->stop = should_stop_exception (bs->bp_location_at);
12427}
12428
f7f9143b
JB
12429/* Implement the PRINT_IT method in the breakpoint_ops structure
12430 for all exception catchpoint kinds. */
12431
12432static enum print_stop_action
761269c8 12433print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12434{
79a45e25 12435 struct ui_out *uiout = current_uiout;
348d480f
PA
12436 struct breakpoint *b = bs->breakpoint_at;
12437
956a9fb9 12438 annotate_catchpoint (b->number);
f7f9143b 12439
112e8700 12440 if (uiout->is_mi_like_p ())
f7f9143b 12441 {
112e8700 12442 uiout->field_string ("reason",
956a9fb9 12443 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12444 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12445 }
12446
112e8700
SM
12447 uiout->text (b->disposition == disp_del
12448 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12449 uiout->field_int ("bkptno", b->number);
12450 uiout->text (", ");
f7f9143b 12451
45db7c09
PA
12452 /* ada_exception_name_addr relies on the selected frame being the
12453 current frame. Need to do this here because this function may be
12454 called more than once when printing a stop, and below, we'll
12455 select the first frame past the Ada run-time (see
12456 ada_find_printable_frame). */
12457 select_frame (get_current_frame ());
12458
f7f9143b
JB
12459 switch (ex)
12460 {
761269c8
JB
12461 case ada_catch_exception:
12462 case ada_catch_exception_unhandled:
9f757bf7 12463 case ada_catch_handlers:
956a9fb9
JB
12464 {
12465 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12466 char exception_name[256];
12467
12468 if (addr != 0)
12469 {
c714b426
PA
12470 read_memory (addr, (gdb_byte *) exception_name,
12471 sizeof (exception_name) - 1);
956a9fb9
JB
12472 exception_name [sizeof (exception_name) - 1] = '\0';
12473 }
12474 else
12475 {
12476 /* For some reason, we were unable to read the exception
12477 name. This could happen if the Runtime was compiled
12478 without debugging info, for instance. In that case,
12479 just replace the exception name by the generic string
12480 "exception" - it will read as "an exception" in the
12481 notification we are about to print. */
967cff16 12482 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12483 }
12484 /* In the case of unhandled exception breakpoints, we print
12485 the exception name as "unhandled EXCEPTION_NAME", to make
12486 it clearer to the user which kind of catchpoint just got
12487 hit. We used ui_out_text to make sure that this extra
12488 info does not pollute the exception name in the MI case. */
761269c8 12489 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12490 uiout->text ("unhandled ");
12491 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12492 }
12493 break;
761269c8 12494 case ada_catch_assert:
956a9fb9
JB
12495 /* In this case, the name of the exception is not really
12496 important. Just print "failed assertion" to make it clearer
12497 that his program just hit an assertion-failure catchpoint.
12498 We used ui_out_text because this info does not belong in
12499 the MI output. */
112e8700 12500 uiout->text ("failed assertion");
956a9fb9 12501 break;
f7f9143b 12502 }
e547c119 12503
6f46ac85 12504 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
e547c119
JB
12505 if (exception_message != NULL)
12506 {
e547c119 12507 uiout->text (" (");
6f46ac85 12508 uiout->field_string ("exception-message", exception_message.get ());
e547c119 12509 uiout->text (")");
e547c119
JB
12510 }
12511
112e8700 12512 uiout->text (" at ");
956a9fb9 12513 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12514
12515 return PRINT_SRC_AND_LOC;
12516}
12517
12518/* Implement the PRINT_ONE method in the breakpoint_ops structure
12519 for all exception catchpoint kinds. */
12520
12521static void
761269c8 12522print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12523 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12524{
79a45e25 12525 struct ui_out *uiout = current_uiout;
28010a5d 12526 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12527 struct value_print_options opts;
12528
12529 get_user_print_options (&opts);
12530 if (opts.addressprint)
f7f9143b
JB
12531 {
12532 annotate_field (4);
112e8700 12533 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12534 }
12535
12536 annotate_field (5);
a6d9a66e 12537 *last_loc = b->loc;
f7f9143b
JB
12538 switch (ex)
12539 {
761269c8 12540 case ada_catch_exception:
bc18fbb5 12541 if (!c->excep_string.empty ())
f7f9143b 12542 {
bc18fbb5
TT
12543 std::string msg = string_printf (_("`%s' Ada exception"),
12544 c->excep_string.c_str ());
28010a5d 12545
112e8700 12546 uiout->field_string ("what", msg);
f7f9143b
JB
12547 }
12548 else
112e8700 12549 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12550
12551 break;
12552
761269c8 12553 case ada_catch_exception_unhandled:
112e8700 12554 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12555 break;
12556
9f757bf7 12557 case ada_catch_handlers:
bc18fbb5 12558 if (!c->excep_string.empty ())
9f757bf7
XR
12559 {
12560 uiout->field_fmt ("what",
12561 _("`%s' Ada exception handlers"),
bc18fbb5 12562 c->excep_string.c_str ());
9f757bf7
XR
12563 }
12564 else
12565 uiout->field_string ("what", "all Ada exceptions handlers");
12566 break;
12567
761269c8 12568 case ada_catch_assert:
112e8700 12569 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12570 break;
12571
12572 default:
12573 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12574 break;
12575 }
12576}
12577
12578/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12579 for all exception catchpoint kinds. */
12580
12581static void
761269c8 12582print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12583 struct breakpoint *b)
12584{
28010a5d 12585 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12586 struct ui_out *uiout = current_uiout;
28010a5d 12587
112e8700 12588 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12589 : _("Catchpoint "));
112e8700
SM
12590 uiout->field_int ("bkptno", b->number);
12591 uiout->text (": ");
00eb2c4a 12592
f7f9143b
JB
12593 switch (ex)
12594 {
761269c8 12595 case ada_catch_exception:
bc18fbb5 12596 if (!c->excep_string.empty ())
00eb2c4a 12597 {
862d101a 12598 std::string info = string_printf (_("`%s' Ada exception"),
bc18fbb5 12599 c->excep_string.c_str ());
862d101a 12600 uiout->text (info.c_str ());
00eb2c4a 12601 }
f7f9143b 12602 else
112e8700 12603 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12604 break;
12605
761269c8 12606 case ada_catch_exception_unhandled:
112e8700 12607 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12608 break;
9f757bf7
XR
12609
12610 case ada_catch_handlers:
bc18fbb5 12611 if (!c->excep_string.empty ())
9f757bf7
XR
12612 {
12613 std::string info
12614 = string_printf (_("`%s' Ada exception handlers"),
bc18fbb5 12615 c->excep_string.c_str ());
9f757bf7
XR
12616 uiout->text (info.c_str ());
12617 }
12618 else
12619 uiout->text (_("all Ada exceptions handlers"));
12620 break;
12621
761269c8 12622 case ada_catch_assert:
112e8700 12623 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12624 break;
12625
12626 default:
12627 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12628 break;
12629 }
12630}
12631
6149aea9
PA
12632/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12633 for all exception catchpoint kinds. */
12634
12635static void
761269c8 12636print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12637 struct breakpoint *b, struct ui_file *fp)
12638{
28010a5d
PA
12639 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12640
6149aea9
PA
12641 switch (ex)
12642 {
761269c8 12643 case ada_catch_exception:
6149aea9 12644 fprintf_filtered (fp, "catch exception");
bc18fbb5
TT
12645 if (!c->excep_string.empty ())
12646 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
6149aea9
PA
12647 break;
12648
761269c8 12649 case ada_catch_exception_unhandled:
78076abc 12650 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12651 break;
12652
9f757bf7
XR
12653 case ada_catch_handlers:
12654 fprintf_filtered (fp, "catch handlers");
12655 break;
12656
761269c8 12657 case ada_catch_assert:
6149aea9
PA
12658 fprintf_filtered (fp, "catch assert");
12659 break;
12660
12661 default:
12662 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12663 }
d9b3f62e 12664 print_recreate_thread (b, fp);
6149aea9
PA
12665}
12666
f7f9143b
JB
12667/* Virtual table for "catch exception" breakpoints. */
12668
28010a5d
PA
12669static struct bp_location *
12670allocate_location_catch_exception (struct breakpoint *self)
12671{
761269c8 12672 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12673}
12674
12675static void
12676re_set_catch_exception (struct breakpoint *b)
12677{
761269c8 12678 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12679}
12680
12681static void
12682check_status_catch_exception (bpstat bs)
12683{
761269c8 12684 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12685}
12686
f7f9143b 12687static enum print_stop_action
348d480f 12688print_it_catch_exception (bpstat bs)
f7f9143b 12689{
761269c8 12690 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12691}
12692
12693static void
a6d9a66e 12694print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12695{
761269c8 12696 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12697}
12698
12699static void
12700print_mention_catch_exception (struct breakpoint *b)
12701{
761269c8 12702 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12703}
12704
6149aea9
PA
12705static void
12706print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12707{
761269c8 12708 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12709}
12710
2060206e 12711static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12712
12713/* Virtual table for "catch exception unhandled" breakpoints. */
12714
28010a5d
PA
12715static struct bp_location *
12716allocate_location_catch_exception_unhandled (struct breakpoint *self)
12717{
761269c8 12718 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12719}
12720
12721static void
12722re_set_catch_exception_unhandled (struct breakpoint *b)
12723{
761269c8 12724 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12725}
12726
12727static void
12728check_status_catch_exception_unhandled (bpstat bs)
12729{
761269c8 12730 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12731}
12732
f7f9143b 12733static enum print_stop_action
348d480f 12734print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12735{
761269c8 12736 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12737}
12738
12739static void
a6d9a66e
UW
12740print_one_catch_exception_unhandled (struct breakpoint *b,
12741 struct bp_location **last_loc)
f7f9143b 12742{
761269c8 12743 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12744}
12745
12746static void
12747print_mention_catch_exception_unhandled (struct breakpoint *b)
12748{
761269c8 12749 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12750}
12751
6149aea9
PA
12752static void
12753print_recreate_catch_exception_unhandled (struct breakpoint *b,
12754 struct ui_file *fp)
12755{
761269c8 12756 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12757}
12758
2060206e 12759static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12760
12761/* Virtual table for "catch assert" breakpoints. */
12762
28010a5d
PA
12763static struct bp_location *
12764allocate_location_catch_assert (struct breakpoint *self)
12765{
761269c8 12766 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12767}
12768
12769static void
12770re_set_catch_assert (struct breakpoint *b)
12771{
761269c8 12772 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12773}
12774
12775static void
12776check_status_catch_assert (bpstat bs)
12777{
761269c8 12778 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12779}
12780
f7f9143b 12781static enum print_stop_action
348d480f 12782print_it_catch_assert (bpstat bs)
f7f9143b 12783{
761269c8 12784 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12785}
12786
12787static void
a6d9a66e 12788print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12789{
761269c8 12790 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12791}
12792
12793static void
12794print_mention_catch_assert (struct breakpoint *b)
12795{
761269c8 12796 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12797}
12798
6149aea9
PA
12799static void
12800print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12801{
761269c8 12802 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12803}
12804
2060206e 12805static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12806
9f757bf7
XR
12807/* Virtual table for "catch handlers" breakpoints. */
12808
12809static struct bp_location *
12810allocate_location_catch_handlers (struct breakpoint *self)
12811{
12812 return allocate_location_exception (ada_catch_handlers, self);
12813}
12814
12815static void
12816re_set_catch_handlers (struct breakpoint *b)
12817{
12818 re_set_exception (ada_catch_handlers, b);
12819}
12820
12821static void
12822check_status_catch_handlers (bpstat bs)
12823{
12824 check_status_exception (ada_catch_handlers, bs);
12825}
12826
12827static enum print_stop_action
12828print_it_catch_handlers (bpstat bs)
12829{
12830 return print_it_exception (ada_catch_handlers, bs);
12831}
12832
12833static void
12834print_one_catch_handlers (struct breakpoint *b,
12835 struct bp_location **last_loc)
12836{
12837 print_one_exception (ada_catch_handlers, b, last_loc);
12838}
12839
12840static void
12841print_mention_catch_handlers (struct breakpoint *b)
12842{
12843 print_mention_exception (ada_catch_handlers, b);
12844}
12845
12846static void
12847print_recreate_catch_handlers (struct breakpoint *b,
12848 struct ui_file *fp)
12849{
12850 print_recreate_exception (ada_catch_handlers, b, fp);
12851}
12852
12853static struct breakpoint_ops catch_handlers_breakpoint_ops;
12854
f7f9143b
JB
12855/* Split the arguments specified in a "catch exception" command.
12856 Set EX to the appropriate catchpoint type.
28010a5d 12857 Set EXCEP_STRING to the name of the specific exception if
5845583d 12858 specified by the user.
9f757bf7
XR
12859 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12860 "catch handlers" command. False otherwise.
5845583d
JB
12861 If a condition is found at the end of the arguments, the condition
12862 expression is stored in COND_STRING (memory must be deallocated
12863 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12864
12865static void
a121b7c1 12866catch_ada_exception_command_split (const char *args,
9f757bf7 12867 bool is_catch_handlers_cmd,
761269c8 12868 enum ada_exception_catchpoint_kind *ex,
bc18fbb5
TT
12869 std::string *excep_string,
12870 std::string *cond_string)
f7f9143b 12871{
bc18fbb5 12872 std::string exception_name;
f7f9143b 12873
bc18fbb5
TT
12874 exception_name = extract_arg (&args);
12875 if (exception_name == "if")
5845583d
JB
12876 {
12877 /* This is not an exception name; this is the start of a condition
12878 expression for a catchpoint on all exceptions. So, "un-get"
12879 this token, and set exception_name to NULL. */
bc18fbb5 12880 exception_name.clear ();
5845583d
JB
12881 args -= 2;
12882 }
f7f9143b 12883
5845583d 12884 /* Check to see if we have a condition. */
f7f9143b 12885
f1735a53 12886 args = skip_spaces (args);
61012eef 12887 if (startswith (args, "if")
5845583d
JB
12888 && (isspace (args[2]) || args[2] == '\0'))
12889 {
12890 args += 2;
f1735a53 12891 args = skip_spaces (args);
5845583d
JB
12892
12893 if (args[0] == '\0')
12894 error (_("Condition missing after `if' keyword"));
bc18fbb5 12895 *cond_string = args;
5845583d
JB
12896
12897 args += strlen (args);
12898 }
12899
12900 /* Check that we do not have any more arguments. Anything else
12901 is unexpected. */
f7f9143b
JB
12902
12903 if (args[0] != '\0')
12904 error (_("Junk at end of expression"));
12905
9f757bf7
XR
12906 if (is_catch_handlers_cmd)
12907 {
12908 /* Catch handling of exceptions. */
12909 *ex = ada_catch_handlers;
12910 *excep_string = exception_name;
12911 }
bc18fbb5 12912 else if (exception_name.empty ())
f7f9143b
JB
12913 {
12914 /* Catch all exceptions. */
761269c8 12915 *ex = ada_catch_exception;
bc18fbb5 12916 excep_string->clear ();
f7f9143b 12917 }
bc18fbb5 12918 else if (exception_name == "unhandled")
f7f9143b
JB
12919 {
12920 /* Catch unhandled exceptions. */
761269c8 12921 *ex = ada_catch_exception_unhandled;
bc18fbb5 12922 excep_string->clear ();
f7f9143b
JB
12923 }
12924 else
12925 {
12926 /* Catch a specific exception. */
761269c8 12927 *ex = ada_catch_exception;
28010a5d 12928 *excep_string = exception_name;
f7f9143b
JB
12929 }
12930}
12931
12932/* Return the name of the symbol on which we should break in order to
12933 implement a catchpoint of the EX kind. */
12934
12935static const char *
761269c8 12936ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12937{
3eecfa55
JB
12938 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12939
12940 gdb_assert (data->exception_info != NULL);
0259addd 12941
f7f9143b
JB
12942 switch (ex)
12943 {
761269c8 12944 case ada_catch_exception:
3eecfa55 12945 return (data->exception_info->catch_exception_sym);
f7f9143b 12946 break;
761269c8 12947 case ada_catch_exception_unhandled:
3eecfa55 12948 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12949 break;
761269c8 12950 case ada_catch_assert:
3eecfa55 12951 return (data->exception_info->catch_assert_sym);
f7f9143b 12952 break;
9f757bf7
XR
12953 case ada_catch_handlers:
12954 return (data->exception_info->catch_handlers_sym);
12955 break;
f7f9143b
JB
12956 default:
12957 internal_error (__FILE__, __LINE__,
12958 _("unexpected catchpoint kind (%d)"), ex);
12959 }
12960}
12961
12962/* Return the breakpoint ops "virtual table" used for catchpoints
12963 of the EX kind. */
12964
c0a91b2b 12965static const struct breakpoint_ops *
761269c8 12966ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12967{
12968 switch (ex)
12969 {
761269c8 12970 case ada_catch_exception:
f7f9143b
JB
12971 return (&catch_exception_breakpoint_ops);
12972 break;
761269c8 12973 case ada_catch_exception_unhandled:
f7f9143b
JB
12974 return (&catch_exception_unhandled_breakpoint_ops);
12975 break;
761269c8 12976 case ada_catch_assert:
f7f9143b
JB
12977 return (&catch_assert_breakpoint_ops);
12978 break;
9f757bf7
XR
12979 case ada_catch_handlers:
12980 return (&catch_handlers_breakpoint_ops);
12981 break;
f7f9143b
JB
12982 default:
12983 internal_error (__FILE__, __LINE__,
12984 _("unexpected catchpoint kind (%d)"), ex);
12985 }
12986}
12987
12988/* Return the condition that will be used to match the current exception
12989 being raised with the exception that the user wants to catch. This
12990 assumes that this condition is used when the inferior just triggered
12991 an exception catchpoint.
cb7de75e 12992 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 12993
cb7de75e 12994static std::string
9f757bf7
XR
12995ada_exception_catchpoint_cond_string (const char *excep_string,
12996 enum ada_exception_catchpoint_kind ex)
f7f9143b 12997{
3d0b0fa3 12998 int i;
cb7de75e 12999 std::string result;
2ff0a947 13000 const char *name;
9f757bf7
XR
13001
13002 if (ex == ada_catch_handlers)
13003 {
13004 /* For exception handlers catchpoints, the condition string does
13005 not use the same parameter as for the other exceptions. */
2ff0a947
TT
13006 name = ("long_integer (GNAT_GCC_exception_Access"
13007 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13008 }
13009 else
2ff0a947 13010 name = "long_integer (e)";
3d0b0fa3 13011
0963b4bd 13012 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13013 runtime units that have been compiled without debugging info; if
28010a5d 13014 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13015 exception (e.g. "constraint_error") then, during the evaluation
13016 of the condition expression, the symbol lookup on this name would
0963b4bd 13017 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13018 may then be set only on user-defined exceptions which have the
13019 same not-fully-qualified name (e.g. my_package.constraint_error).
13020
13021 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13022 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13023 exception constraint_error" is rewritten into "catch exception
13024 standard.constraint_error".
13025
13026 If an exception named contraint_error is defined in another package of
13027 the inferior program, then the only way to specify this exception as a
13028 breakpoint condition is to use its fully-qualified named:
2ff0a947
TT
13029 e.g. my_package.constraint_error.
13030
13031 Furthermore, in some situations a standard exception's symbol may
13032 be present in more than one objfile, because the compiler may
13033 choose to emit copy relocations for them. So, we have to compare
13034 against all the possible addresses. */
3d0b0fa3 13035
2ff0a947
TT
13036 /* Storage for a rewritten symbol name. */
13037 std::string std_name;
3d0b0fa3
JB
13038 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13039 {
28010a5d 13040 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13041 {
2ff0a947
TT
13042 std_name = std::string ("standard.") + excep_string;
13043 excep_string = std_name.c_str ();
9f757bf7 13044 break;
3d0b0fa3
JB
13045 }
13046 }
9f757bf7 13047
2ff0a947
TT
13048 excep_string = ada_encode (excep_string);
13049 std::vector<struct bound_minimal_symbol> symbols
13050 = ada_lookup_simple_minsyms (excep_string);
bde09ab7 13051 for (const bound_minimal_symbol &msym : symbols)
2ff0a947
TT
13052 {
13053 if (!result.empty ())
13054 result += " or ";
13055 string_appendf (result, "%s = %s", name,
13056 pulongest (BMSYMBOL_VALUE_ADDRESS (msym)));
13057 }
9f757bf7 13058
9f757bf7 13059 return result;
f7f9143b
JB
13060}
13061
13062/* Return the symtab_and_line that should be used to insert an exception
13063 catchpoint of the TYPE kind.
13064
28010a5d
PA
13065 ADDR_STRING returns the name of the function where the real
13066 breakpoint that implements the catchpoints is set, depending on the
13067 type of catchpoint we need to create. */
f7f9143b
JB
13068
13069static struct symtab_and_line
bc18fbb5 13070ada_exception_sal (enum ada_exception_catchpoint_kind ex,
cc12f4a8 13071 std::string *addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13072{
13073 const char *sym_name;
13074 struct symbol *sym;
f7f9143b 13075
0259addd
JB
13076 /* First, find out which exception support info to use. */
13077 ada_exception_support_info_sniffer ();
13078
13079 /* Then lookup the function on which we will break in order to catch
f7f9143b 13080 the Ada exceptions requested by the user. */
f7f9143b
JB
13081 sym_name = ada_exception_sym_name (ex);
13082 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13083
57aff202
JB
13084 if (sym == NULL)
13085 error (_("Catchpoint symbol not found: %s"), sym_name);
13086
13087 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13088 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
f7f9143b
JB
13089
13090 /* Set ADDR_STRING. */
cc12f4a8 13091 *addr_string = sym_name;
f7f9143b 13092
f7f9143b 13093 /* Set OPS. */
4b9eee8c 13094 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13095
f17011e0 13096 return find_function_start_sal (sym, 1);
f7f9143b
JB
13097}
13098
b4a5b78b 13099/* Create an Ada exception catchpoint.
f7f9143b 13100
b4a5b78b 13101 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13102
bc18fbb5 13103 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
2df4d1d5 13104 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
bc18fbb5 13105 of the exception to which this catchpoint applies.
2df4d1d5 13106
bc18fbb5 13107 COND_STRING, if not empty, is the catchpoint condition.
f7f9143b 13108
b4a5b78b
JB
13109 TEMPFLAG, if nonzero, means that the underlying breakpoint
13110 should be temporary.
28010a5d 13111
b4a5b78b 13112 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13113
349774ef 13114void
28010a5d 13115create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13116 enum ada_exception_catchpoint_kind ex_kind,
bc18fbb5 13117 const std::string &excep_string,
56ecd069 13118 const std::string &cond_string,
28010a5d 13119 int tempflag,
349774ef 13120 int disabled,
28010a5d
PA
13121 int from_tty)
13122{
cc12f4a8 13123 std::string addr_string;
b4a5b78b 13124 const struct breakpoint_ops *ops = NULL;
bc18fbb5 13125 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
28010a5d 13126
b270e6f9 13127 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
cc12f4a8 13128 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (),
349774ef 13129 ops, tempflag, disabled, from_tty);
28010a5d 13130 c->excep_string = excep_string;
9f757bf7 13131 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13132 if (!cond_string.empty ())
13133 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13134 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13135}
13136
9ac4176b
PA
13137/* Implement the "catch exception" command. */
13138
13139static void
eb4c3f4a 13140catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13141 struct cmd_list_element *command)
13142{
a121b7c1 13143 const char *arg = arg_entry;
9ac4176b
PA
13144 struct gdbarch *gdbarch = get_current_arch ();
13145 int tempflag;
761269c8 13146 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13147 std::string excep_string;
56ecd069 13148 std::string cond_string;
9ac4176b
PA
13149
13150 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13151
13152 if (!arg)
13153 arg = "";
9f757bf7 13154 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
bc18fbb5 13155 &cond_string);
9f757bf7
XR
13156 create_ada_exception_catchpoint (gdbarch, ex_kind,
13157 excep_string, cond_string,
13158 tempflag, 1 /* enabled */,
13159 from_tty);
13160}
13161
13162/* Implement the "catch handlers" command. */
13163
13164static void
13165catch_ada_handlers_command (const char *arg_entry, int from_tty,
13166 struct cmd_list_element *command)
13167{
13168 const char *arg = arg_entry;
13169 struct gdbarch *gdbarch = get_current_arch ();
13170 int tempflag;
13171 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13172 std::string excep_string;
56ecd069 13173 std::string cond_string;
9f757bf7
XR
13174
13175 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13176
13177 if (!arg)
13178 arg = "";
13179 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
bc18fbb5 13180 &cond_string);
b4a5b78b
JB
13181 create_ada_exception_catchpoint (gdbarch, ex_kind,
13182 excep_string, cond_string,
349774ef
JB
13183 tempflag, 1 /* enabled */,
13184 from_tty);
9ac4176b
PA
13185}
13186
71bed2db
TT
13187/* Completion function for the Ada "catch" commands. */
13188
13189static void
13190catch_ada_completer (struct cmd_list_element *cmd, completion_tracker &tracker,
13191 const char *text, const char *word)
13192{
13193 std::vector<ada_exc_info> exceptions = ada_exceptions_list (NULL);
13194
13195 for (const ada_exc_info &info : exceptions)
13196 {
13197 if (startswith (info.name, word))
b02f78f9 13198 tracker.add_completion (make_unique_xstrdup (info.name));
71bed2db
TT
13199 }
13200}
13201
b4a5b78b 13202/* Split the arguments specified in a "catch assert" command.
5845583d 13203
b4a5b78b
JB
13204 ARGS contains the command's arguments (or the empty string if
13205 no arguments were passed).
5845583d
JB
13206
13207 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13208 (the memory needs to be deallocated after use). */
5845583d 13209
b4a5b78b 13210static void
56ecd069 13211catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13212{
f1735a53 13213 args = skip_spaces (args);
f7f9143b 13214
5845583d 13215 /* Check whether a condition was provided. */
61012eef 13216 if (startswith (args, "if")
5845583d 13217 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13218 {
5845583d 13219 args += 2;
f1735a53 13220 args = skip_spaces (args);
5845583d
JB
13221 if (args[0] == '\0')
13222 error (_("condition missing after `if' keyword"));
56ecd069 13223 cond_string.assign (args);
f7f9143b
JB
13224 }
13225
5845583d
JB
13226 /* Otherwise, there should be no other argument at the end of
13227 the command. */
13228 else if (args[0] != '\0')
13229 error (_("Junk at end of arguments."));
f7f9143b
JB
13230}
13231
9ac4176b
PA
13232/* Implement the "catch assert" command. */
13233
13234static void
eb4c3f4a 13235catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13236 struct cmd_list_element *command)
13237{
a121b7c1 13238 const char *arg = arg_entry;
9ac4176b
PA
13239 struct gdbarch *gdbarch = get_current_arch ();
13240 int tempflag;
56ecd069 13241 std::string cond_string;
9ac4176b
PA
13242
13243 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13244
13245 if (!arg)
13246 arg = "";
56ecd069 13247 catch_ada_assert_command_split (arg, cond_string);
761269c8 13248 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
241db429 13249 "", cond_string,
349774ef
JB
13250 tempflag, 1 /* enabled */,
13251 from_tty);
9ac4176b 13252}
778865d3
JB
13253
13254/* Return non-zero if the symbol SYM is an Ada exception object. */
13255
13256static int
13257ada_is_exception_sym (struct symbol *sym)
13258{
a737d952 13259 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
778865d3
JB
13260
13261 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13262 && SYMBOL_CLASS (sym) != LOC_BLOCK
13263 && SYMBOL_CLASS (sym) != LOC_CONST
13264 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13265 && type_name != NULL && strcmp (type_name, "exception") == 0);
13266}
13267
13268/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13269 Ada exception object. This matches all exceptions except the ones
13270 defined by the Ada language. */
13271
13272static int
13273ada_is_non_standard_exception_sym (struct symbol *sym)
13274{
13275 int i;
13276
13277 if (!ada_is_exception_sym (sym))
13278 return 0;
13279
13280 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13281 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13282 return 0; /* A standard exception. */
13283
13284 /* Numeric_Error is also a standard exception, so exclude it.
13285 See the STANDARD_EXC description for more details as to why
13286 this exception is not listed in that array. */
13287 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13288 return 0;
13289
13290 return 1;
13291}
13292
ab816a27 13293/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13294 objects.
13295
13296 The comparison is determined first by exception name, and then
13297 by exception address. */
13298
ab816a27 13299bool
cc536b21 13300ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13301{
778865d3
JB
13302 int result;
13303
ab816a27
TT
13304 result = strcmp (name, other.name);
13305 if (result < 0)
13306 return true;
13307 if (result == 0 && addr < other.addr)
13308 return true;
13309 return false;
13310}
778865d3 13311
ab816a27 13312bool
cc536b21 13313ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13314{
13315 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13316}
13317
13318/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13319 routine, but keeping the first SKIP elements untouched.
13320
13321 All duplicates are also removed. */
13322
13323static void
ab816a27 13324sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13325 int skip)
13326{
ab816a27
TT
13327 std::sort (exceptions->begin () + skip, exceptions->end ());
13328 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13329 exceptions->end ());
778865d3
JB
13330}
13331
778865d3
JB
13332/* Add all exceptions defined by the Ada standard whose name match
13333 a regular expression.
13334
13335 If PREG is not NULL, then this regexp_t object is used to
13336 perform the symbol name matching. Otherwise, no name-based
13337 filtering is performed.
13338
13339 EXCEPTIONS is a vector of exceptions to which matching exceptions
13340 gets pushed. */
13341
13342static void
2d7cc5c7 13343ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13344 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13345{
13346 int i;
13347
13348 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13349 {
13350 if (preg == NULL
2d7cc5c7 13351 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13352 {
13353 struct bound_minimal_symbol msymbol
13354 = ada_lookup_simple_minsym (standard_exc[i]);
13355
13356 if (msymbol.minsym != NULL)
13357 {
13358 struct ada_exc_info info
77e371c0 13359 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13360
ab816a27 13361 exceptions->push_back (info);
778865d3
JB
13362 }
13363 }
13364 }
13365}
13366
13367/* Add all Ada exceptions defined locally and accessible from the given
13368 FRAME.
13369
13370 If PREG is not NULL, then this regexp_t object is used to
13371 perform the symbol name matching. Otherwise, no name-based
13372 filtering is performed.
13373
13374 EXCEPTIONS is a vector of exceptions to which matching exceptions
13375 gets pushed. */
13376
13377static void
2d7cc5c7
PA
13378ada_add_exceptions_from_frame (compiled_regex *preg,
13379 struct frame_info *frame,
ab816a27 13380 std::vector<ada_exc_info> *exceptions)
778865d3 13381{
3977b71f 13382 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13383
13384 while (block != 0)
13385 {
13386 struct block_iterator iter;
13387 struct symbol *sym;
13388
13389 ALL_BLOCK_SYMBOLS (block, iter, sym)
13390 {
13391 switch (SYMBOL_CLASS (sym))
13392 {
13393 case LOC_TYPEDEF:
13394 case LOC_BLOCK:
13395 case LOC_CONST:
13396 break;
13397 default:
13398 if (ada_is_exception_sym (sym))
13399 {
13400 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13401 SYMBOL_VALUE_ADDRESS (sym)};
13402
ab816a27 13403 exceptions->push_back (info);
778865d3
JB
13404 }
13405 }
13406 }
13407 if (BLOCK_FUNCTION (block) != NULL)
13408 break;
13409 block = BLOCK_SUPERBLOCK (block);
13410 }
13411}
13412
14bc53a8
PA
13413/* Return true if NAME matches PREG or if PREG is NULL. */
13414
13415static bool
2d7cc5c7 13416name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13417{
13418 return (preg == NULL
2d7cc5c7 13419 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13420}
13421
778865d3
JB
13422/* Add all exceptions defined globally whose name name match
13423 a regular expression, excluding standard exceptions.
13424
13425 The reason we exclude standard exceptions is that they need
13426 to be handled separately: Standard exceptions are defined inside
13427 a runtime unit which is normally not compiled with debugging info,
13428 and thus usually do not show up in our symbol search. However,
13429 if the unit was in fact built with debugging info, we need to
13430 exclude them because they would duplicate the entry we found
13431 during the special loop that specifically searches for those
13432 standard exceptions.
13433
13434 If PREG is not NULL, then this regexp_t object is used to
13435 perform the symbol name matching. Otherwise, no name-based
13436 filtering is performed.
13437
13438 EXCEPTIONS is a vector of exceptions to which matching exceptions
13439 gets pushed. */
13440
13441static void
2d7cc5c7 13442ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13443 std::vector<ada_exc_info> *exceptions)
778865d3 13444{
14bc53a8
PA
13445 /* In Ada, the symbol "search name" is a linkage name, whereas the
13446 regular expression used to do the matching refers to the natural
13447 name. So match against the decoded name. */
13448 expand_symtabs_matching (NULL,
b5ec771e 13449 lookup_name_info::match_any (),
14bc53a8
PA
13450 [&] (const char *search_name)
13451 {
13452 const char *decoded = ada_decode (search_name);
13453 return name_matches_regex (decoded, preg);
13454 },
13455 NULL,
13456 VARIABLES_DOMAIN);
778865d3 13457
2030c079 13458 for (objfile *objfile : current_program_space->objfiles ())
778865d3 13459 {
b669c953 13460 for (compunit_symtab *s : objfile->compunits ())
778865d3 13461 {
d8aeb77f
TT
13462 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13463 int i;
778865d3 13464
d8aeb77f
TT
13465 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13466 {
582942f4 13467 const struct block *b = BLOCKVECTOR_BLOCK (bv, i);
d8aeb77f
TT
13468 struct block_iterator iter;
13469 struct symbol *sym;
778865d3 13470
d8aeb77f
TT
13471 ALL_BLOCK_SYMBOLS (b, iter, sym)
13472 if (ada_is_non_standard_exception_sym (sym)
13473 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13474 {
13475 struct ada_exc_info info
13476 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13477
13478 exceptions->push_back (info);
13479 }
13480 }
778865d3
JB
13481 }
13482 }
13483}
13484
13485/* Implements ada_exceptions_list with the regular expression passed
13486 as a regex_t, rather than a string.
13487
13488 If not NULL, PREG is used to filter out exceptions whose names
13489 do not match. Otherwise, all exceptions are listed. */
13490
ab816a27 13491static std::vector<ada_exc_info>
2d7cc5c7 13492ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13493{
ab816a27 13494 std::vector<ada_exc_info> result;
778865d3
JB
13495 int prev_len;
13496
13497 /* First, list the known standard exceptions. These exceptions
13498 need to be handled separately, as they are usually defined in
13499 runtime units that have been compiled without debugging info. */
13500
13501 ada_add_standard_exceptions (preg, &result);
13502
13503 /* Next, find all exceptions whose scope is local and accessible
13504 from the currently selected frame. */
13505
13506 if (has_stack_frames ())
13507 {
ab816a27 13508 prev_len = result.size ();
778865d3
JB
13509 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13510 &result);
ab816a27 13511 if (result.size () > prev_len)
778865d3
JB
13512 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13513 }
13514
13515 /* Add all exceptions whose scope is global. */
13516
ab816a27 13517 prev_len = result.size ();
778865d3 13518 ada_add_global_exceptions (preg, &result);
ab816a27 13519 if (result.size () > prev_len)
778865d3
JB
13520 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13521
778865d3
JB
13522 return result;
13523}
13524
13525/* Return a vector of ada_exc_info.
13526
13527 If REGEXP is NULL, all exceptions are included in the result.
13528 Otherwise, it should contain a valid regular expression,
13529 and only the exceptions whose names match that regular expression
13530 are included in the result.
13531
13532 The exceptions are sorted in the following order:
13533 - Standard exceptions (defined by the Ada language), in
13534 alphabetical order;
13535 - Exceptions only visible from the current frame, in
13536 alphabetical order;
13537 - Exceptions whose scope is global, in alphabetical order. */
13538
ab816a27 13539std::vector<ada_exc_info>
778865d3
JB
13540ada_exceptions_list (const char *regexp)
13541{
2d7cc5c7
PA
13542 if (regexp == NULL)
13543 return ada_exceptions_list_1 (NULL);
778865d3 13544
2d7cc5c7
PA
13545 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13546 return ada_exceptions_list_1 (&reg);
778865d3
JB
13547}
13548
13549/* Implement the "info exceptions" command. */
13550
13551static void
1d12d88f 13552info_exceptions_command (const char *regexp, int from_tty)
778865d3 13553{
778865d3 13554 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13555
ab816a27 13556 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13557
13558 if (regexp != NULL)
13559 printf_filtered
13560 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13561 else
13562 printf_filtered (_("All defined Ada exceptions:\n"));
13563
ab816a27
TT
13564 for (const ada_exc_info &info : exceptions)
13565 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13566}
13567
4c4b4cd2
PH
13568 /* Operators */
13569/* Information about operators given special treatment in functions
13570 below. */
13571/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13572
13573#define ADA_OPERATORS \
13574 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13575 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13576 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13577 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13578 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13579 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13580 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13581 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13582 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13583 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13584 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13585 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13586 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13587 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13588 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13589 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13590 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13591 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13592 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13593
13594static void
554794dc
SDJ
13595ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13596 int *argsp)
4c4b4cd2
PH
13597{
13598 switch (exp->elts[pc - 1].opcode)
13599 {
76a01679 13600 default:
4c4b4cd2
PH
13601 operator_length_standard (exp, pc, oplenp, argsp);
13602 break;
13603
13604#define OP_DEFN(op, len, args, binop) \
13605 case op: *oplenp = len; *argsp = args; break;
13606 ADA_OPERATORS;
13607#undef OP_DEFN
52ce6436
PH
13608
13609 case OP_AGGREGATE:
13610 *oplenp = 3;
13611 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13612 break;
13613
13614 case OP_CHOICES:
13615 *oplenp = 3;
13616 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13617 break;
4c4b4cd2
PH
13618 }
13619}
13620
c0201579
JK
13621/* Implementation of the exp_descriptor method operator_check. */
13622
13623static int
13624ada_operator_check (struct expression *exp, int pos,
13625 int (*objfile_func) (struct objfile *objfile, void *data),
13626 void *data)
13627{
13628 const union exp_element *const elts = exp->elts;
13629 struct type *type = NULL;
13630
13631 switch (elts[pos].opcode)
13632 {
13633 case UNOP_IN_RANGE:
13634 case UNOP_QUAL:
13635 type = elts[pos + 1].type;
13636 break;
13637
13638 default:
13639 return operator_check_standard (exp, pos, objfile_func, data);
13640 }
13641
13642 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13643
13644 if (type && TYPE_OBJFILE (type)
13645 && (*objfile_func) (TYPE_OBJFILE (type), data))
13646 return 1;
13647
13648 return 0;
13649}
13650
a121b7c1 13651static const char *
4c4b4cd2
PH
13652ada_op_name (enum exp_opcode opcode)
13653{
13654 switch (opcode)
13655 {
76a01679 13656 default:
4c4b4cd2 13657 return op_name_standard (opcode);
52ce6436 13658
4c4b4cd2
PH
13659#define OP_DEFN(op, len, args, binop) case op: return #op;
13660 ADA_OPERATORS;
13661#undef OP_DEFN
52ce6436
PH
13662
13663 case OP_AGGREGATE:
13664 return "OP_AGGREGATE";
13665 case OP_CHOICES:
13666 return "OP_CHOICES";
13667 case OP_NAME:
13668 return "OP_NAME";
4c4b4cd2
PH
13669 }
13670}
13671
13672/* As for operator_length, but assumes PC is pointing at the first
13673 element of the operator, and gives meaningful results only for the
52ce6436 13674 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13675
13676static void
76a01679
JB
13677ada_forward_operator_length (struct expression *exp, int pc,
13678 int *oplenp, int *argsp)
4c4b4cd2 13679{
76a01679 13680 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13681 {
13682 default:
13683 *oplenp = *argsp = 0;
13684 break;
52ce6436 13685
4c4b4cd2
PH
13686#define OP_DEFN(op, len, args, binop) \
13687 case op: *oplenp = len; *argsp = args; break;
13688 ADA_OPERATORS;
13689#undef OP_DEFN
52ce6436
PH
13690
13691 case OP_AGGREGATE:
13692 *oplenp = 3;
13693 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13694 break;
13695
13696 case OP_CHOICES:
13697 *oplenp = 3;
13698 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13699 break;
13700
13701 case OP_STRING:
13702 case OP_NAME:
13703 {
13704 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13705
52ce6436
PH
13706 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13707 *argsp = 0;
13708 break;
13709 }
4c4b4cd2
PH
13710 }
13711}
13712
13713static int
13714ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13715{
13716 enum exp_opcode op = exp->elts[elt].opcode;
13717 int oplen, nargs;
13718 int pc = elt;
13719 int i;
76a01679 13720
4c4b4cd2
PH
13721 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13722
76a01679 13723 switch (op)
4c4b4cd2 13724 {
76a01679 13725 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13726 case OP_ATR_FIRST:
13727 case OP_ATR_LAST:
13728 case OP_ATR_LENGTH:
13729 case OP_ATR_IMAGE:
13730 case OP_ATR_MAX:
13731 case OP_ATR_MIN:
13732 case OP_ATR_MODULUS:
13733 case OP_ATR_POS:
13734 case OP_ATR_SIZE:
13735 case OP_ATR_TAG:
13736 case OP_ATR_VAL:
13737 break;
13738
13739 case UNOP_IN_RANGE:
13740 case UNOP_QUAL:
323e0a4a
AC
13741 /* XXX: gdb_sprint_host_address, type_sprint */
13742 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13743 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13744 fprintf_filtered (stream, " (");
13745 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13746 fprintf_filtered (stream, ")");
13747 break;
13748 case BINOP_IN_BOUNDS:
52ce6436
PH
13749 fprintf_filtered (stream, " (%d)",
13750 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13751 break;
13752 case TERNOP_IN_RANGE:
13753 break;
13754
52ce6436
PH
13755 case OP_AGGREGATE:
13756 case OP_OTHERS:
13757 case OP_DISCRETE_RANGE:
13758 case OP_POSITIONAL:
13759 case OP_CHOICES:
13760 break;
13761
13762 case OP_NAME:
13763 case OP_STRING:
13764 {
13765 char *name = &exp->elts[elt + 2].string;
13766 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13767
52ce6436
PH
13768 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13769 break;
13770 }
13771
4c4b4cd2
PH
13772 default:
13773 return dump_subexp_body_standard (exp, stream, elt);
13774 }
13775
13776 elt += oplen;
13777 for (i = 0; i < nargs; i += 1)
13778 elt = dump_subexp (exp, stream, elt);
13779
13780 return elt;
13781}
13782
13783/* The Ada extension of print_subexp (q.v.). */
13784
76a01679
JB
13785static void
13786ada_print_subexp (struct expression *exp, int *pos,
13787 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13788{
52ce6436 13789 int oplen, nargs, i;
4c4b4cd2
PH
13790 int pc = *pos;
13791 enum exp_opcode op = exp->elts[pc].opcode;
13792
13793 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13794
52ce6436 13795 *pos += oplen;
4c4b4cd2
PH
13796 switch (op)
13797 {
13798 default:
52ce6436 13799 *pos -= oplen;
4c4b4cd2
PH
13800 print_subexp_standard (exp, pos, stream, prec);
13801 return;
13802
13803 case OP_VAR_VALUE:
4c4b4cd2
PH
13804 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13805 return;
13806
13807 case BINOP_IN_BOUNDS:
323e0a4a 13808 /* XXX: sprint_subexp */
4c4b4cd2 13809 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13810 fputs_filtered (" in ", stream);
4c4b4cd2 13811 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13812 fputs_filtered ("'range", stream);
4c4b4cd2 13813 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13814 fprintf_filtered (stream, "(%ld)",
13815 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13816 return;
13817
13818 case TERNOP_IN_RANGE:
4c4b4cd2 13819 if (prec >= PREC_EQUAL)
76a01679 13820 fputs_filtered ("(", stream);
323e0a4a 13821 /* XXX: sprint_subexp */
4c4b4cd2 13822 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13823 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13824 print_subexp (exp, pos, stream, PREC_EQUAL);
13825 fputs_filtered (" .. ", stream);
13826 print_subexp (exp, pos, stream, PREC_EQUAL);
13827 if (prec >= PREC_EQUAL)
76a01679
JB
13828 fputs_filtered (")", stream);
13829 return;
4c4b4cd2
PH
13830
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:
4c4b4cd2 13842 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13843 {
13844 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13845 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13846 &type_print_raw_options);
76a01679
JB
13847 *pos += 3;
13848 }
4c4b4cd2 13849 else
76a01679 13850 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13851 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13852 if (nargs > 1)
76a01679
JB
13853 {
13854 int tem;
5b4ee69b 13855
76a01679
JB
13856 for (tem = 1; tem < nargs; tem += 1)
13857 {
13858 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13859 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13860 }
13861 fputs_filtered (")", stream);
13862 }
4c4b4cd2 13863 return;
14f9c5c9 13864
4c4b4cd2 13865 case UNOP_QUAL:
4c4b4cd2
PH
13866 type_print (exp->elts[pc + 1].type, "", stream, 0);
13867 fputs_filtered ("'(", stream);
13868 print_subexp (exp, pos, stream, PREC_PREFIX);
13869 fputs_filtered (")", stream);
13870 return;
14f9c5c9 13871
4c4b4cd2 13872 case UNOP_IN_RANGE:
323e0a4a 13873 /* XXX: sprint_subexp */
4c4b4cd2 13874 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13875 fputs_filtered (" in ", stream);
79d43c61
TT
13876 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13877 &type_print_raw_options);
4c4b4cd2 13878 return;
52ce6436
PH
13879
13880 case OP_DISCRETE_RANGE:
13881 print_subexp (exp, pos, stream, PREC_SUFFIX);
13882 fputs_filtered ("..", stream);
13883 print_subexp (exp, pos, stream, PREC_SUFFIX);
13884 return;
13885
13886 case OP_OTHERS:
13887 fputs_filtered ("others => ", stream);
13888 print_subexp (exp, pos, stream, PREC_SUFFIX);
13889 return;
13890
13891 case OP_CHOICES:
13892 for (i = 0; i < nargs-1; i += 1)
13893 {
13894 if (i > 0)
13895 fputs_filtered ("|", stream);
13896 print_subexp (exp, pos, stream, PREC_SUFFIX);
13897 }
13898 fputs_filtered (" => ", stream);
13899 print_subexp (exp, pos, stream, PREC_SUFFIX);
13900 return;
13901
13902 case OP_POSITIONAL:
13903 print_subexp (exp, pos, stream, PREC_SUFFIX);
13904 return;
13905
13906 case OP_AGGREGATE:
13907 fputs_filtered ("(", stream);
13908 for (i = 0; i < nargs; i += 1)
13909 {
13910 if (i > 0)
13911 fputs_filtered (", ", stream);
13912 print_subexp (exp, pos, stream, PREC_SUFFIX);
13913 }
13914 fputs_filtered (")", stream);
13915 return;
4c4b4cd2
PH
13916 }
13917}
14f9c5c9
AS
13918
13919/* Table mapping opcodes into strings for printing operators
13920 and precedences of the operators. */
13921
d2e4a39e
AS
13922static const struct op_print ada_op_print_tab[] = {
13923 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13924 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13925 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13926 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13927 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13928 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13929 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13930 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13931 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13932 {">=", BINOP_GEQ, PREC_ORDER, 0},
13933 {">", BINOP_GTR, PREC_ORDER, 0},
13934 {"<", BINOP_LESS, PREC_ORDER, 0},
13935 {">>", BINOP_RSH, PREC_SHIFT, 0},
13936 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13937 {"+", BINOP_ADD, PREC_ADD, 0},
13938 {"-", BINOP_SUB, PREC_ADD, 0},
13939 {"&", BINOP_CONCAT, PREC_ADD, 0},
13940 {"*", BINOP_MUL, PREC_MUL, 0},
13941 {"/", BINOP_DIV, PREC_MUL, 0},
13942 {"rem", BINOP_REM, PREC_MUL, 0},
13943 {"mod", BINOP_MOD, PREC_MUL, 0},
13944 {"**", BINOP_EXP, PREC_REPEAT, 0},
13945 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13946 {"-", UNOP_NEG, PREC_PREFIX, 0},
13947 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13948 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13949 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13950 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13951 {".all", UNOP_IND, PREC_SUFFIX, 1},
13952 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13953 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 13954 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
13955};
13956\f
72d5681a
PH
13957enum ada_primitive_types {
13958 ada_primitive_type_int,
13959 ada_primitive_type_long,
13960 ada_primitive_type_short,
13961 ada_primitive_type_char,
13962 ada_primitive_type_float,
13963 ada_primitive_type_double,
13964 ada_primitive_type_void,
13965 ada_primitive_type_long_long,
13966 ada_primitive_type_long_double,
13967 ada_primitive_type_natural,
13968 ada_primitive_type_positive,
13969 ada_primitive_type_system_address,
08f49010 13970 ada_primitive_type_storage_offset,
72d5681a
PH
13971 nr_ada_primitive_types
13972};
6c038f32
PH
13973
13974static void
d4a9a881 13975ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13976 struct language_arch_info *lai)
13977{
d4a9a881 13978 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13979
72d5681a 13980 lai->primitive_type_vector
d4a9a881 13981 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13982 struct type *);
e9bb382b
UW
13983
13984 lai->primitive_type_vector [ada_primitive_type_int]
13985 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13986 0, "integer");
13987 lai->primitive_type_vector [ada_primitive_type_long]
13988 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13989 0, "long_integer");
13990 lai->primitive_type_vector [ada_primitive_type_short]
13991 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13992 0, "short_integer");
13993 lai->string_char_type
13994 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 13995 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
13996 lai->primitive_type_vector [ada_primitive_type_float]
13997 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 13998 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
13999 lai->primitive_type_vector [ada_primitive_type_double]
14000 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14001 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14002 lai->primitive_type_vector [ada_primitive_type_long_long]
14003 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14004 0, "long_long_integer");
14005 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14006 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14007 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14008 lai->primitive_type_vector [ada_primitive_type_natural]
14009 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14010 0, "natural");
14011 lai->primitive_type_vector [ada_primitive_type_positive]
14012 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14013 0, "positive");
14014 lai->primitive_type_vector [ada_primitive_type_void]
14015 = builtin->builtin_void;
14016
14017 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14018 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14019 "void"));
72d5681a
PH
14020 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14021 = "system__address";
fbb06eb1 14022
08f49010
XR
14023 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14024 type. This is a signed integral type whose size is the same as
14025 the size of addresses. */
14026 {
14027 unsigned int addr_length = TYPE_LENGTH
14028 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14029
14030 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14031 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14032 "storage_offset");
14033 }
14034
47e729a8 14035 lai->bool_type_symbol = NULL;
fbb06eb1 14036 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14037}
6c038f32
PH
14038\f
14039 /* Language vector */
14040
14041/* Not really used, but needed in the ada_language_defn. */
14042
14043static void
6c7a06a3 14044emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14045{
6c7a06a3 14046 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14047}
14048
14049static int
410a0ff2 14050parse (struct parser_state *ps)
6c038f32
PH
14051{
14052 warnings_issued = 0;
410a0ff2 14053 return ada_parse (ps);
6c038f32
PH
14054}
14055
14056static const struct exp_descriptor ada_exp_descriptor = {
14057 ada_print_subexp,
14058 ada_operator_length,
c0201579 14059 ada_operator_check,
6c038f32
PH
14060 ada_op_name,
14061 ada_dump_subexp_body,
14062 ada_evaluate_subexp
14063};
14064
b5ec771e
PA
14065/* symbol_name_matcher_ftype adapter for wild_match. */
14066
14067static bool
14068do_wild_match (const char *symbol_search_name,
14069 const lookup_name_info &lookup_name,
a207cff2 14070 completion_match_result *comp_match_res)
b5ec771e
PA
14071{
14072 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14073}
14074
14075/* symbol_name_matcher_ftype adapter for full_match. */
14076
14077static bool
14078do_full_match (const char *symbol_search_name,
14079 const lookup_name_info &lookup_name,
a207cff2 14080 completion_match_result *comp_match_res)
b5ec771e
PA
14081{
14082 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14083}
14084
a2cd4f14
JB
14085/* symbol_name_matcher_ftype for exact (verbatim) matches. */
14086
14087static bool
14088do_exact_match (const char *symbol_search_name,
14089 const lookup_name_info &lookup_name,
14090 completion_match_result *comp_match_res)
14091{
14092 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0;
14093}
14094
b5ec771e
PA
14095/* Build the Ada lookup name for LOOKUP_NAME. */
14096
14097ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14098{
14099 const std::string &user_name = lookup_name.name ();
14100
14101 if (user_name[0] == '<')
14102 {
14103 if (user_name.back () == '>')
14104 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14105 else
14106 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14107 m_encoded_p = true;
14108 m_verbatim_p = true;
14109 m_wild_match_p = false;
14110 m_standard_p = false;
14111 }
14112 else
14113 {
14114 m_verbatim_p = false;
14115
14116 m_encoded_p = user_name.find ("__") != std::string::npos;
14117
14118 if (!m_encoded_p)
14119 {
14120 const char *folded = ada_fold_name (user_name.c_str ());
14121 const char *encoded = ada_encode_1 (folded, false);
14122 if (encoded != NULL)
14123 m_encoded_name = encoded;
14124 else
14125 m_encoded_name = user_name;
14126 }
14127 else
14128 m_encoded_name = user_name;
14129
14130 /* Handle the 'package Standard' special case. See description
14131 of m_standard_p. */
14132 if (startswith (m_encoded_name.c_str (), "standard__"))
14133 {
14134 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14135 m_standard_p = true;
14136 }
14137 else
14138 m_standard_p = false;
74ccd7f5 14139
b5ec771e
PA
14140 /* If the name contains a ".", then the user is entering a fully
14141 qualified entity name, and the match must not be done in wild
14142 mode. Similarly, if the user wants to complete what looks
14143 like an encoded name, the match must not be done in wild
14144 mode. Also, in the standard__ special case always do
14145 non-wild matching. */
14146 m_wild_match_p
14147 = (lookup_name.match_type () != symbol_name_match_type::FULL
14148 && !m_encoded_p
14149 && !m_standard_p
14150 && user_name.find ('.') == std::string::npos);
14151 }
14152}
14153
14154/* symbol_name_matcher_ftype method for Ada. This only handles
14155 completion mode. */
14156
14157static bool
14158ada_symbol_name_matches (const char *symbol_search_name,
14159 const lookup_name_info &lookup_name,
a207cff2 14160 completion_match_result *comp_match_res)
74ccd7f5 14161{
b5ec771e
PA
14162 return lookup_name.ada ().matches (symbol_search_name,
14163 lookup_name.match_type (),
a207cff2 14164 comp_match_res);
b5ec771e
PA
14165}
14166
de63c46b
PA
14167/* A name matcher that matches the symbol name exactly, with
14168 strcmp. */
14169
14170static bool
14171literal_symbol_name_matcher (const char *symbol_search_name,
14172 const lookup_name_info &lookup_name,
14173 completion_match_result *comp_match_res)
14174{
14175 const std::string &name = lookup_name.name ();
14176
14177 int cmp = (lookup_name.completion_mode ()
14178 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14179 : strcmp (symbol_search_name, name.c_str ()));
14180 if (cmp == 0)
14181 {
14182 if (comp_match_res != NULL)
14183 comp_match_res->set_match (symbol_search_name);
14184 return true;
14185 }
14186 else
14187 return false;
14188}
14189
b5ec771e
PA
14190/* Implement the "la_get_symbol_name_matcher" language_defn method for
14191 Ada. */
14192
14193static symbol_name_matcher_ftype *
14194ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14195{
de63c46b
PA
14196 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14197 return literal_symbol_name_matcher;
14198
b5ec771e
PA
14199 if (lookup_name.completion_mode ())
14200 return ada_symbol_name_matches;
74ccd7f5 14201 else
b5ec771e
PA
14202 {
14203 if (lookup_name.ada ().wild_match_p ())
14204 return do_wild_match;
a2cd4f14
JB
14205 else if (lookup_name.ada ().verbatim_p ())
14206 return do_exact_match;
b5ec771e
PA
14207 else
14208 return do_full_match;
14209 }
74ccd7f5
JB
14210}
14211
a5ee536b
JB
14212/* Implement the "la_read_var_value" language_defn method for Ada. */
14213
14214static struct value *
63e43d3a
PMR
14215ada_read_var_value (struct symbol *var, const struct block *var_block,
14216 struct frame_info *frame)
a5ee536b 14217{
a5ee536b
JB
14218 /* The only case where default_read_var_value is not sufficient
14219 is when VAR is a renaming... */
c0e70c62
TT
14220 if (frame != nullptr)
14221 {
14222 const struct block *frame_block = get_frame_block (frame, NULL);
14223 if (frame_block != nullptr && ada_is_renaming_symbol (var))
14224 return ada_read_renaming_var_value (var, frame_block);
14225 }
a5ee536b
JB
14226
14227 /* This is a typical case where we expect the default_read_var_value
14228 function to work. */
63e43d3a 14229 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14230}
14231
56618e20
TT
14232static const char *ada_extensions[] =
14233{
14234 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14235};
14236
47e77640 14237extern const struct language_defn ada_language_defn = {
6c038f32 14238 "ada", /* Language name */
6abde28f 14239 "Ada",
6c038f32 14240 language_ada,
6c038f32 14241 range_check_off,
6c038f32
PH
14242 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14243 that's not quite what this means. */
6c038f32 14244 array_row_major,
9a044a89 14245 macro_expansion_no,
56618e20 14246 ada_extensions,
6c038f32
PH
14247 &ada_exp_descriptor,
14248 parse,
6c038f32
PH
14249 resolve,
14250 ada_printchar, /* Print a character constant */
14251 ada_printstr, /* Function to print string constant */
14252 emit_char, /* Function to print single char (not used) */
6c038f32 14253 ada_print_type, /* Print a type using appropriate syntax */
be942545 14254 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14255 ada_val_print, /* Print a value using appropriate syntax */
14256 ada_value_print, /* Print a top-level value */
a5ee536b 14257 ada_read_var_value, /* la_read_var_value */
6c038f32 14258 NULL, /* Language specific skip_trampoline */
2b2d9e11 14259 NULL, /* name_of_this */
59cc4834 14260 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14261 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14262 basic_lookup_transparent_type, /* lookup_transparent_type */
14263 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14264 ada_sniff_from_mangled_name,
0963b4bd
MS
14265 NULL, /* Language specific
14266 class_name_from_physname */
6c038f32
PH
14267 ada_op_print_tab, /* expression operators for printing */
14268 0, /* c-style arrays */
14269 1, /* String lower bound */
6c038f32 14270 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14271 ada_collect_symbol_completion_matches,
72d5681a 14272 ada_language_arch_info,
e79af960 14273 ada_print_array_index,
41f1b697 14274 default_pass_by_reference,
ae6a3a4c 14275 c_get_string,
e2b7af72 14276 ada_watch_location_expression,
b5ec771e 14277 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14278 ada_iterate_over_symbols,
5ffa0793 14279 default_search_name_hash,
a53b64ea 14280 &ada_varobj_ops,
bb2ec1b3 14281 NULL,
721b08c6 14282 NULL,
4be290b2 14283 ada_is_string_type,
721b08c6 14284 "(...)" /* la_struct_too_deep_ellipsis */
6c038f32
PH
14285};
14286
5bf03f13
JB
14287/* Command-list for the "set/show ada" prefix command. */
14288static struct cmd_list_element *set_ada_list;
14289static struct cmd_list_element *show_ada_list;
14290
14291/* Implement the "set ada" prefix command. */
14292
14293static void
981a3fb3 14294set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14295{
14296 printf_unfiltered (_(\
14297"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14298 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14299}
14300
14301/* Implement the "show ada" prefix command. */
14302
14303static void
981a3fb3 14304show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14305{
14306 cmd_show_list (show_ada_list, from_tty, "");
14307}
14308
2060206e
PA
14309static void
14310initialize_ada_catchpoint_ops (void)
14311{
14312 struct breakpoint_ops *ops;
14313
14314 initialize_breakpoint_ops ();
14315
14316 ops = &catch_exception_breakpoint_ops;
14317 *ops = bkpt_breakpoint_ops;
2060206e
PA
14318 ops->allocate_location = allocate_location_catch_exception;
14319 ops->re_set = re_set_catch_exception;
14320 ops->check_status = check_status_catch_exception;
14321 ops->print_it = print_it_catch_exception;
14322 ops->print_one = print_one_catch_exception;
14323 ops->print_mention = print_mention_catch_exception;
14324 ops->print_recreate = print_recreate_catch_exception;
14325
14326 ops = &catch_exception_unhandled_breakpoint_ops;
14327 *ops = bkpt_breakpoint_ops;
2060206e
PA
14328 ops->allocate_location = allocate_location_catch_exception_unhandled;
14329 ops->re_set = re_set_catch_exception_unhandled;
14330 ops->check_status = check_status_catch_exception_unhandled;
14331 ops->print_it = print_it_catch_exception_unhandled;
14332 ops->print_one = print_one_catch_exception_unhandled;
14333 ops->print_mention = print_mention_catch_exception_unhandled;
14334 ops->print_recreate = print_recreate_catch_exception_unhandled;
14335
14336 ops = &catch_assert_breakpoint_ops;
14337 *ops = bkpt_breakpoint_ops;
2060206e
PA
14338 ops->allocate_location = allocate_location_catch_assert;
14339 ops->re_set = re_set_catch_assert;
14340 ops->check_status = check_status_catch_assert;
14341 ops->print_it = print_it_catch_assert;
14342 ops->print_one = print_one_catch_assert;
14343 ops->print_mention = print_mention_catch_assert;
14344 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14345
14346 ops = &catch_handlers_breakpoint_ops;
14347 *ops = bkpt_breakpoint_ops;
14348 ops->allocate_location = allocate_location_catch_handlers;
14349 ops->re_set = re_set_catch_handlers;
14350 ops->check_status = check_status_catch_handlers;
14351 ops->print_it = print_it_catch_handlers;
14352 ops->print_one = print_one_catch_handlers;
14353 ops->print_mention = print_mention_catch_handlers;
14354 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14355}
14356
3d9434b5
JB
14357/* This module's 'new_objfile' observer. */
14358
14359static void
14360ada_new_objfile_observer (struct objfile *objfile)
14361{
14362 ada_clear_symbol_cache ();
14363}
14364
14365/* This module's 'free_objfile' observer. */
14366
14367static void
14368ada_free_objfile_observer (struct objfile *objfile)
14369{
14370 ada_clear_symbol_cache ();
14371}
14372
d2e4a39e 14373void
6c038f32 14374_initialize_ada_language (void)
14f9c5c9 14375{
2060206e
PA
14376 initialize_ada_catchpoint_ops ();
14377
5bf03f13 14378 add_prefix_cmd ("ada", no_class, set_ada_command,
470678d7 14379 _("Prefix command for changing Ada-specific settings"),
5bf03f13
JB
14380 &set_ada_list, "set ada ", 0, &setlist);
14381
14382 add_prefix_cmd ("ada", no_class, show_ada_command,
14383 _("Generic command for showing Ada-specific settings."),
14384 &show_ada_list, "show ada ", 0, &showlist);
14385
14386 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14387 &trust_pad_over_xvs, _("\
14388Enable or disable an optimization trusting PAD types over XVS types"), _("\
14389Show whether an optimization trusting PAD types over XVS types is activated"),
14390 _("\
14391This is related to the encoding used by the GNAT compiler. The debugger\n\
14392should normally trust the contents of PAD types, but certain older versions\n\
14393of GNAT have a bug that sometimes causes the information in the PAD type\n\
14394to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14395work around this bug. It is always safe to turn this option \"off\", but\n\
14396this incurs a slight performance penalty, so it is recommended to NOT change\n\
14397this option to \"off\" unless necessary."),
14398 NULL, NULL, &set_ada_list, &show_ada_list);
14399
d72413e6
PMR
14400 add_setshow_boolean_cmd ("print-signatures", class_vars,
14401 &print_signatures, _("\
14402Enable or disable the output of formal and return types for functions in the \
14403overloads selection menu"), _("\
14404Show whether the output of formal and return types for functions in the \
14405overloads selection menu is activated"),
14406 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14407
9ac4176b
PA
14408 add_catch_command ("exception", _("\
14409Catch Ada exceptions, when raised.\n\
60a90376
JB
14410Usage: catch exception [ ARG ]\n\
14411\n\
14412Without any argument, stop when any Ada exception is raised.\n\
14413If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14414being raised does not have a handler (and will therefore lead to the task's\n\
14415termination).\n\
14416Otherwise, the catchpoint only stops when the name of the exception being\n\
14417raised is the same as ARG."),
9ac4176b 14418 catch_ada_exception_command,
71bed2db 14419 catch_ada_completer,
9ac4176b
PA
14420 CATCH_PERMANENT,
14421 CATCH_TEMPORARY);
9f757bf7
XR
14422
14423 add_catch_command ("handlers", _("\
14424Catch Ada exceptions, when handled.\n\
14425With an argument, catch only exceptions with the given name."),
14426 catch_ada_handlers_command,
71bed2db 14427 catch_ada_completer,
9f757bf7
XR
14428 CATCH_PERMANENT,
14429 CATCH_TEMPORARY);
9ac4176b
PA
14430 add_catch_command ("assert", _("\
14431Catch failed Ada assertions, when raised.\n\
14432With an argument, catch only exceptions with the given name."),
14433 catch_assert_command,
14434 NULL,
14435 CATCH_PERMANENT,
14436 CATCH_TEMPORARY);
14437
6c038f32 14438 varsize_limit = 65536;
3fcded8f
JB
14439 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14440 &varsize_limit, _("\
14441Set the maximum number of bytes allowed in a variable-size object."), _("\
14442Show the maximum number of bytes allowed in a variable-size object."), _("\
14443Attempts to access an object whose size is not a compile-time constant\n\
14444and exceeds this limit will cause an error."),
14445 NULL, NULL, &setlist, &showlist);
6c038f32 14446
778865d3
JB
14447 add_info ("exceptions", info_exceptions_command,
14448 _("\
14449List all Ada exception names.\n\
14450If a regular expression is passed as an argument, only those matching\n\
14451the regular expression are listed."));
14452
c6044dd1
JB
14453 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14454 _("Set Ada maintenance-related variables."),
14455 &maint_set_ada_cmdlist, "maintenance set ada ",
14456 0/*allow-unknown*/, &maintenance_set_cmdlist);
14457
14458 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14459 _("Show Ada maintenance-related variables"),
14460 &maint_show_ada_cmdlist, "maintenance show ada ",
14461 0/*allow-unknown*/, &maintenance_show_cmdlist);
14462
14463 add_setshow_boolean_cmd
14464 ("ignore-descriptive-types", class_maintenance,
14465 &ada_ignore_descriptive_types_p,
14466 _("Set whether descriptive types generated by GNAT should be ignored."),
14467 _("Show whether descriptive types generated by GNAT should be ignored."),
14468 _("\
14469When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14470DWARF attribute."),
14471 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14472
459a2e4c
TT
14473 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14474 NULL, xcalloc, xfree);
6b69afc4 14475
3d9434b5 14476 /* The ada-lang observers. */
76727919
TT
14477 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14478 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14479 gdb::observers::inferior_exit.attach (ada_inferior_exit);
14f9c5c9 14480}