]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Change all_objfiles_safe adapter to be a method on program_space
[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"
4c4b4cd2
PH
24#include "gdb_regex.h"
25#include "frame.h"
14f9c5c9
AS
26#include "symtab.h"
27#include "gdbtypes.h"
28#include "gdbcmd.h"
29#include "expression.h"
30#include "parser-defs.h"
31#include "language.h"
a53b64ea 32#include "varobj.h"
14f9c5c9
AS
33#include "c-lang.h"
34#include "inferior.h"
35#include "symfile.h"
36#include "objfiles.h"
37#include "breakpoint.h"
38#include "gdbcore.h"
4c4b4cd2
PH
39#include "hashtab.h"
40#include "gdb_obstack.h"
14f9c5c9 41#include "ada-lang.h"
4c4b4cd2 42#include "completer.h"
53ce3c39 43#include <sys/stat.h>
14f9c5c9 44#include "ui-out.h"
fe898f56 45#include "block.h"
04714b91 46#include "infcall.h"
de4f826b 47#include "dictionary.h"
f7f9143b
JB
48#include "annotate.h"
49#include "valprint.h"
9bbc9174 50#include "source.h"
76727919 51#include "observable.h"
2ba95b9b 52#include "vec.h"
692465f1 53#include "stack.h"
fa864999 54#include "gdb_vecs.h"
79d43c61 55#include "typeprint.h"
22cee43f 56#include "namespace.h"
14f9c5c9 57
ccefe4c4 58#include "psymtab.h"
40bc484c 59#include "value.h"
956a9fb9 60#include "mi/mi-common.h"
9ac4176b 61#include "arch-utils.h"
0fcd72ba 62#include "cli/cli-utils.h"
14bc53a8 63#include "common/function-view.h"
d5722aa2 64#include "common/byte-vector.h"
ab816a27 65#include <algorithm>
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40bc484c 107static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 108
4c4b4cd2 109static void ada_add_block_symbols (struct obstack *,
b5ec771e
PA
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
14f9c5c9 113
22cee43f 114static void ada_add_all_symbols (struct obstack *, const struct block *,
b5ec771e
PA
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
22cee43f 117
d12307c1 118static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 119
76a01679 120static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 121 const struct block *);
14f9c5c9 122
4c4b4cd2
PH
123static int num_defns_collected (struct obstack *);
124
d12307c1 125static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 126
e9d9f57e 127static struct value *resolve_subexp (expression_up *, int *, int,
76a01679 128 struct type *);
14f9c5c9 129
e9d9f57e 130static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 131 struct symbol *, const struct block *);
14f9c5c9 132
d2e4a39e 133static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 134
a121b7c1 135static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
136
137static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 138
d2e4a39e 139static int numeric_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int integer_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int scalar_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int discrete_type_p (struct type *);
14f9c5c9 146
aeb5907d
JB
147static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 153 const struct block *);
aeb5907d 154
a121b7c1 155static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 156 int, int);
4c4b4cd2 157
d2e4a39e 158static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 159
b4ba55a1
JB
160static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
d2e4a39e 163static int is_dynamic_field (struct type *, int);
14f9c5c9 164
10a2c479 165static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 166 const gdb_byte *,
4c4b4cd2
PH
167 CORE_ADDR, struct value *);
168
169static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 170
28c85d6c 171static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 172
d2e4a39e 173static struct type *to_static_fixed_type (struct type *);
f192137b 174static struct type *static_unwrap_type (struct type *type);
14f9c5c9 175
d2e4a39e 176static struct value *unwrap_value (struct value *);
14f9c5c9 177
ad82864c 178static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 179
ad82864c 180static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 181
ad82864c
JB
182static long decode_packed_array_bitsize (struct type *);
183
184static struct value *decode_constrained_packed_array (struct value *);
185
186static int ada_is_packed_array_type (struct type *);
187
188static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 189
d2e4a39e 190static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 191 struct value **);
14f9c5c9 192
4c4b4cd2
PH
193static struct value *coerce_unspec_val_to_type (struct value *,
194 struct type *);
14f9c5c9 195
d2e4a39e 196static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 197
d2e4a39e 198static int equiv_types (struct type *, struct type *);
14f9c5c9 199
d2e4a39e 200static int is_name_suffix (const char *);
14f9c5c9 201
73589123
PH
202static int advance_wild_match (const char **, const char *, int);
203
b5ec771e 204static bool wild_match (const char *name, const char *patn);
14f9c5c9 205
d2e4a39e 206static struct value *ada_coerce_ref (struct value *);
14f9c5c9 207
4c4b4cd2
PH
208static LONGEST pos_atr (struct value *);
209
3cb382c9 210static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 211
d2e4a39e 212static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 213
4c4b4cd2
PH
214static struct symbol *standard_lookup (const char *, const struct block *,
215 domain_enum);
14f9c5c9 216
108d56a4 217static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
218 struct type *);
219
220static struct value *ada_value_primitive_field (struct value *, int, int,
221 struct type *);
222
0d5cff50 223static int find_struct_field (const char *, struct type *, int,
52ce6436 224 struct type **, int *, int *, int *, int *);
4c4b4cd2 225
d12307c1 226static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
227 struct value **, int, const char *,
228 struct type *);
229
4c4b4cd2
PH
230static int ada_is_direct_array_type (struct type *);
231
72d5681a
PH
232static void ada_language_arch_info (struct gdbarch *,
233 struct language_arch_info *);
714e53ab 234
52ce6436
PH
235static struct value *ada_index_struct_field (int, struct value *, int,
236 struct type *);
237
238static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
239 struct expression *,
240 int *, enum noside);
52ce6436
PH
241
242static void aggregate_assign_from_choices (struct value *, struct value *,
243 struct expression *,
244 int *, LONGEST *, int *,
245 int, LONGEST, LONGEST);
246
247static void aggregate_assign_positional (struct value *, struct value *,
248 struct expression *,
249 int *, LONGEST *, int *, int,
250 LONGEST, LONGEST);
251
252
253static void aggregate_assign_others (struct value *, struct value *,
254 struct expression *,
255 int *, LONGEST *, int, LONGEST, LONGEST);
256
257
258static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
259
260
261static struct value *ada_evaluate_subexp (struct type *, struct expression *,
262 int *, enum noside);
263
264static void ada_forward_operator_length (struct expression *, int, int *,
265 int *);
852dff6c
JB
266
267static struct type *ada_find_any_type (const char *name);
b5ec771e
PA
268
269static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
270 (const lookup_name_info &lookup_name);
271
4c4b4cd2
PH
272\f
273
ee01b665
JB
274/* The result of a symbol lookup to be stored in our symbol cache. */
275
276struct cache_entry
277{
278 /* The name used to perform the lookup. */
279 const char *name;
280 /* The namespace used during the lookup. */
fe978cb0 281 domain_enum domain;
ee01b665
JB
282 /* The symbol returned by the lookup, or NULL if no matching symbol
283 was found. */
284 struct symbol *sym;
285 /* The block where the symbol was found, or NULL if no matching
286 symbol was found. */
287 const struct block *block;
288 /* A pointer to the next entry with the same hash. */
289 struct cache_entry *next;
290};
291
292/* The Ada symbol cache, used to store the result of Ada-mode symbol
293 lookups in the course of executing the user's commands.
294
295 The cache is implemented using a simple, fixed-sized hash.
296 The size is fixed on the grounds that there are not likely to be
297 all that many symbols looked up during any given session, regardless
298 of the size of the symbol table. If we decide to go to a resizable
299 table, let's just use the stuff from libiberty instead. */
300
301#define HASH_SIZE 1009
302
303struct ada_symbol_cache
304{
305 /* An obstack used to store the entries in our cache. */
306 struct obstack cache_space;
307
308 /* The root of the hash table used to implement our symbol cache. */
309 struct cache_entry *root[HASH_SIZE];
310};
311
312static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 313
4c4b4cd2 314/* Maximum-sized dynamic type. */
14f9c5c9
AS
315static unsigned int varsize_limit;
316
67cb5b2d 317static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
318#ifdef VMS
319 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
320#else
14f9c5c9 321 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 322#endif
14f9c5c9 323
4c4b4cd2 324/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 325static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 326 = "__gnat_ada_main_program_name";
14f9c5c9 327
4c4b4cd2
PH
328/* Limit on the number of warnings to raise per expression evaluation. */
329static int warning_limit = 2;
330
331/* Number of warning messages issued; reset to 0 by cleanups after
332 expression evaluation. */
333static int warnings_issued = 0;
334
335static const char *known_runtime_file_name_patterns[] = {
336 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
337};
338
339static const char *known_auxiliary_function_name_patterns[] = {
340 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
341};
342
c6044dd1
JB
343/* Maintenance-related settings for this module. */
344
345static struct cmd_list_element *maint_set_ada_cmdlist;
346static struct cmd_list_element *maint_show_ada_cmdlist;
347
348/* Implement the "maintenance set ada" (prefix) command. */
349
350static void
981a3fb3 351maint_set_ada_cmd (const char *args, int from_tty)
c6044dd1 352{
635c7e8a
TT
353 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
354 gdb_stdout);
c6044dd1
JB
355}
356
357/* Implement the "maintenance show ada" (prefix) command. */
358
359static void
981a3fb3 360maint_show_ada_cmd (const char *args, int from_tty)
c6044dd1
JB
361{
362 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
363}
364
365/* The "maintenance ada set/show ignore-descriptive-type" value. */
366
367static int ada_ignore_descriptive_types_p = 0;
368
e802dbe0
JB
369 /* Inferior-specific data. */
370
371/* Per-inferior data for this module. */
372
373struct ada_inferior_data
374{
375 /* The ada__tags__type_specific_data type, which is used when decoding
376 tagged types. With older versions of GNAT, this type was directly
377 accessible through a component ("tsd") in the object tag. But this
378 is no longer the case, so we cache it for each inferior. */
379 struct type *tsd_type;
3eecfa55
JB
380
381 /* The exception_support_info data. This data is used to determine
382 how to implement support for Ada exception catchpoints in a given
383 inferior. */
384 const struct exception_support_info *exception_info;
e802dbe0
JB
385};
386
387/* Our key to this module's inferior data. */
388static const struct inferior_data *ada_inferior_data;
389
390/* A cleanup routine for our inferior data. */
391static void
392ada_inferior_data_cleanup (struct inferior *inf, void *arg)
393{
394 struct ada_inferior_data *data;
395
9a3c8263 396 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
397 if (data != NULL)
398 xfree (data);
399}
400
401/* Return our inferior data for the given inferior (INF).
402
403 This function always returns a valid pointer to an allocated
404 ada_inferior_data structure. If INF's inferior data has not
405 been previously set, this functions creates a new one with all
406 fields set to zero, sets INF's inferior to it, and then returns
407 a pointer to that newly allocated ada_inferior_data. */
408
409static struct ada_inferior_data *
410get_ada_inferior_data (struct inferior *inf)
411{
412 struct ada_inferior_data *data;
413
9a3c8263 414 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
415 if (data == NULL)
416 {
41bf6aca 417 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
418 set_inferior_data (inf, ada_inferior_data, data);
419 }
420
421 return data;
422}
423
424/* Perform all necessary cleanups regarding our module's inferior data
425 that is required after the inferior INF just exited. */
426
427static void
428ada_inferior_exit (struct inferior *inf)
429{
430 ada_inferior_data_cleanup (inf, NULL);
431 set_inferior_data (inf, ada_inferior_data, NULL);
432}
433
ee01b665
JB
434
435 /* program-space-specific data. */
436
437/* This module's per-program-space data. */
438struct ada_pspace_data
439{
440 /* The Ada symbol cache. */
441 struct ada_symbol_cache *sym_cache;
442};
443
444/* Key to our per-program-space data. */
445static const struct program_space_data *ada_pspace_data_handle;
446
447/* Return this module's data for the given program space (PSPACE).
448 If not is found, add a zero'ed one now.
449
450 This function always returns a valid object. */
451
452static struct ada_pspace_data *
453get_ada_pspace_data (struct program_space *pspace)
454{
455 struct ada_pspace_data *data;
456
9a3c8263
SM
457 data = ((struct ada_pspace_data *)
458 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
459 if (data == NULL)
460 {
461 data = XCNEW (struct ada_pspace_data);
462 set_program_space_data (pspace, ada_pspace_data_handle, data);
463 }
464
465 return data;
466}
467
468/* The cleanup callback for this module's per-program-space data. */
469
470static void
471ada_pspace_data_cleanup (struct program_space *pspace, void *data)
472{
9a3c8263 473 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
474
475 if (pspace_data->sym_cache != NULL)
476 ada_free_symbol_cache (pspace_data->sym_cache);
477 xfree (pspace_data);
478}
479
4c4b4cd2
PH
480 /* Utilities */
481
720d1a40 482/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 483 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
484
485 Normally, we really expect a typedef type to only have 1 typedef layer.
486 In other words, we really expect the target type of a typedef type to be
487 a non-typedef type. This is particularly true for Ada units, because
488 the language does not have a typedef vs not-typedef distinction.
489 In that respect, the Ada compiler has been trying to eliminate as many
490 typedef definitions in the debugging information, since they generally
491 do not bring any extra information (we still use typedef under certain
492 circumstances related mostly to the GNAT encoding).
493
494 Unfortunately, we have seen situations where the debugging information
495 generated by the compiler leads to such multiple typedef layers. For
496 instance, consider the following example with stabs:
497
498 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
499 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
500
501 This is an error in the debugging information which causes type
502 pck__float_array___XUP to be defined twice, and the second time,
503 it is defined as a typedef of a typedef.
504
505 This is on the fringe of legality as far as debugging information is
506 concerned, and certainly unexpected. But it is easy to handle these
507 situations correctly, so we can afford to be lenient in this case. */
508
509static struct type *
510ada_typedef_target_type (struct type *type)
511{
512 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
513 type = TYPE_TARGET_TYPE (type);
514 return type;
515}
516
41d27058
JB
517/* Given DECODED_NAME a string holding a symbol name in its
518 decoded form (ie using the Ada dotted notation), returns
519 its unqualified name. */
520
521static const char *
522ada_unqualified_name (const char *decoded_name)
523{
2b0f535a
JB
524 const char *result;
525
526 /* If the decoded name starts with '<', it means that the encoded
527 name does not follow standard naming conventions, and thus that
528 it is not your typical Ada symbol name. Trying to unqualify it
529 is therefore pointless and possibly erroneous. */
530 if (decoded_name[0] == '<')
531 return decoded_name;
532
533 result = strrchr (decoded_name, '.');
41d27058
JB
534 if (result != NULL)
535 result++; /* Skip the dot... */
536 else
537 result = decoded_name;
538
539 return result;
540}
541
39e7af3e 542/* Return a string starting with '<', followed by STR, and '>'. */
41d27058 543
39e7af3e 544static std::string
41d27058
JB
545add_angle_brackets (const char *str)
546{
39e7af3e 547 return string_printf ("<%s>", str);
41d27058 548}
96d887e8 549
67cb5b2d 550static const char *
4c4b4cd2
PH
551ada_get_gdb_completer_word_break_characters (void)
552{
553 return ada_completer_word_break_characters;
554}
555
e79af960
JB
556/* Print an array element index using the Ada syntax. */
557
558static void
559ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 560 const struct value_print_options *options)
e79af960 561{
79a45b7d 562 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
563 fprintf_filtered (stream, " => ");
564}
565
e2b7af72
JB
566/* la_watch_location_expression for Ada. */
567
568gdb::unique_xmalloc_ptr<char>
569ada_watch_location_expression (struct type *type, CORE_ADDR addr)
570{
571 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type)));
572 std::string name = type_to_string (type);
573 return gdb::unique_xmalloc_ptr<char>
574 (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr)));
575}
576
f27cf670 577/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 578 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 579 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 580
f27cf670
AS
581void *
582grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 583{
d2e4a39e
AS
584 if (*size < min_size)
585 {
586 *size *= 2;
587 if (*size < min_size)
4c4b4cd2 588 *size = min_size;
f27cf670 589 vect = xrealloc (vect, *size * element_size);
d2e4a39e 590 }
f27cf670 591 return vect;
14f9c5c9
AS
592}
593
594/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 595 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
596
597static int
ebf56fd3 598field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
599{
600 int len = strlen (target);
5b4ee69b 601
d2e4a39e 602 return
4c4b4cd2
PH
603 (strncmp (field_name, target, len) == 0
604 && (field_name[len] == '\0'
61012eef 605 || (startswith (field_name + len, "___")
76a01679
JB
606 && strcmp (field_name + strlen (field_name) - 6,
607 "___XVN") != 0)));
14f9c5c9
AS
608}
609
610
872c8b51
JB
611/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
612 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
613 and return its index. This function also handles fields whose name
614 have ___ suffixes because the compiler sometimes alters their name
615 by adding such a suffix to represent fields with certain constraints.
616 If the field could not be found, return a negative number if
617 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
618
619int
620ada_get_field_index (const struct type *type, const char *field_name,
621 int maybe_missing)
622{
623 int fieldno;
872c8b51
JB
624 struct type *struct_type = check_typedef ((struct type *) type);
625
626 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
627 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
628 return fieldno;
629
630 if (!maybe_missing)
323e0a4a 631 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 632 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
633
634 return -1;
635}
636
637/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
638
639int
d2e4a39e 640ada_name_prefix_len (const char *name)
14f9c5c9
AS
641{
642 if (name == NULL)
643 return 0;
d2e4a39e 644 else
14f9c5c9 645 {
d2e4a39e 646 const char *p = strstr (name, "___");
5b4ee69b 647
14f9c5c9 648 if (p == NULL)
4c4b4cd2 649 return strlen (name);
14f9c5c9 650 else
4c4b4cd2 651 return p - name;
14f9c5c9
AS
652 }
653}
654
4c4b4cd2
PH
655/* Return non-zero if SUFFIX is a suffix of STR.
656 Return zero if STR is null. */
657
14f9c5c9 658static int
d2e4a39e 659is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
660{
661 int len1, len2;
5b4ee69b 662
14f9c5c9
AS
663 if (str == NULL)
664 return 0;
665 len1 = strlen (str);
666 len2 = strlen (suffix);
4c4b4cd2 667 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
668}
669
4c4b4cd2
PH
670/* The contents of value VAL, treated as a value of type TYPE. The
671 result is an lval in memory if VAL is. */
14f9c5c9 672
d2e4a39e 673static struct value *
4c4b4cd2 674coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 675{
61ee279c 676 type = ada_check_typedef (type);
df407dfe 677 if (value_type (val) == type)
4c4b4cd2 678 return val;
d2e4a39e 679 else
14f9c5c9 680 {
4c4b4cd2
PH
681 struct value *result;
682
683 /* Make sure that the object size is not unreasonable before
684 trying to allocate some memory for it. */
c1b5a1a6 685 ada_ensure_varsize_limit (type);
4c4b4cd2 686
41e8491f
JK
687 if (value_lazy (val)
688 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
689 result = allocate_value_lazy (type);
690 else
691 {
692 result = allocate_value (type);
9a0dc9e3 693 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 694 }
74bcbdf3 695 set_value_component_location (result, val);
9bbda503
AC
696 set_value_bitsize (result, value_bitsize (val));
697 set_value_bitpos (result, value_bitpos (val));
42ae5230 698 set_value_address (result, value_address (val));
14f9c5c9
AS
699 return result;
700 }
701}
702
fc1a4b47
AC
703static const gdb_byte *
704cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
705{
706 if (valaddr == NULL)
707 return NULL;
708 else
709 return valaddr + offset;
710}
711
712static CORE_ADDR
ebf56fd3 713cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
714{
715 if (address == 0)
716 return 0;
d2e4a39e 717 else
14f9c5c9
AS
718 return address + offset;
719}
720
4c4b4cd2
PH
721/* Issue a warning (as for the definition of warning in utils.c, but
722 with exactly one argument rather than ...), unless the limit on the
723 number of warnings has passed during the evaluation of the current
724 expression. */
a2249542 725
77109804
AC
726/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
727 provided by "complaint". */
a0b31db1 728static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 729
14f9c5c9 730static void
a2249542 731lim_warning (const char *format, ...)
14f9c5c9 732{
a2249542 733 va_list args;
a2249542 734
5b4ee69b 735 va_start (args, format);
4c4b4cd2
PH
736 warnings_issued += 1;
737 if (warnings_issued <= warning_limit)
a2249542
MK
738 vwarning (format, args);
739
740 va_end (args);
4c4b4cd2
PH
741}
742
714e53ab
PH
743/* Issue an error if the size of an object of type T is unreasonable,
744 i.e. if it would be a bad idea to allocate a value of this type in
745 GDB. */
746
c1b5a1a6
JB
747void
748ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
749{
750 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 751 error (_("object size is larger than varsize-limit"));
714e53ab
PH
752}
753
0963b4bd 754/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 755static LONGEST
c3e5cd34 756max_of_size (int size)
4c4b4cd2 757{
76a01679 758 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 759
76a01679 760 return top_bit | (top_bit - 1);
4c4b4cd2
PH
761}
762
0963b4bd 763/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 764static LONGEST
c3e5cd34 765min_of_size (int size)
4c4b4cd2 766{
c3e5cd34 767 return -max_of_size (size) - 1;
4c4b4cd2
PH
768}
769
0963b4bd 770/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 771static ULONGEST
c3e5cd34 772umax_of_size (int size)
4c4b4cd2 773{
76a01679 774 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 775
76a01679 776 return top_bit | (top_bit - 1);
4c4b4cd2
PH
777}
778
0963b4bd 779/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
780static LONGEST
781max_of_type (struct type *t)
4c4b4cd2 782{
c3e5cd34
PH
783 if (TYPE_UNSIGNED (t))
784 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
785 else
786 return max_of_size (TYPE_LENGTH (t));
787}
788
0963b4bd 789/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
790static LONGEST
791min_of_type (struct type *t)
792{
793 if (TYPE_UNSIGNED (t))
794 return 0;
795 else
796 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
797}
798
799/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
800LONGEST
801ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 802{
c3345124 803 type = resolve_dynamic_type (type, NULL, 0);
76a01679 804 switch (TYPE_CODE (type))
4c4b4cd2
PH
805 {
806 case TYPE_CODE_RANGE:
690cc4eb 807 return TYPE_HIGH_BOUND (type);
4c4b4cd2 808 case TYPE_CODE_ENUM:
14e75d8e 809 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
810 case TYPE_CODE_BOOL:
811 return 1;
812 case TYPE_CODE_CHAR:
76a01679 813 case TYPE_CODE_INT:
690cc4eb 814 return max_of_type (type);
4c4b4cd2 815 default:
43bbcdc2 816 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
817 }
818}
819
14e75d8e 820/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
821LONGEST
822ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 823{
c3345124 824 type = resolve_dynamic_type (type, NULL, 0);
76a01679 825 switch (TYPE_CODE (type))
4c4b4cd2
PH
826 {
827 case TYPE_CODE_RANGE:
690cc4eb 828 return TYPE_LOW_BOUND (type);
4c4b4cd2 829 case TYPE_CODE_ENUM:
14e75d8e 830 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
831 case TYPE_CODE_BOOL:
832 return 0;
833 case TYPE_CODE_CHAR:
76a01679 834 case TYPE_CODE_INT:
690cc4eb 835 return min_of_type (type);
4c4b4cd2 836 default:
43bbcdc2 837 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
838 }
839}
840
841/* The identity on non-range types. For range types, the underlying
76a01679 842 non-range scalar type. */
4c4b4cd2
PH
843
844static struct type *
18af8284 845get_base_type (struct type *type)
4c4b4cd2
PH
846{
847 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
848 {
76a01679
JB
849 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
850 return type;
4c4b4cd2
PH
851 type = TYPE_TARGET_TYPE (type);
852 }
853 return type;
14f9c5c9 854}
41246937
JB
855
856/* Return a decoded version of the given VALUE. This means returning
857 a value whose type is obtained by applying all the GNAT-specific
858 encondings, making the resulting type a static but standard description
859 of the initial type. */
860
861struct value *
862ada_get_decoded_value (struct value *value)
863{
864 struct type *type = ada_check_typedef (value_type (value));
865
866 if (ada_is_array_descriptor_type (type)
867 || (ada_is_constrained_packed_array_type (type)
868 && TYPE_CODE (type) != TYPE_CODE_PTR))
869 {
870 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
871 value = ada_coerce_to_simple_array_ptr (value);
872 else
873 value = ada_coerce_to_simple_array (value);
874 }
875 else
876 value = ada_to_fixed_value (value);
877
878 return value;
879}
880
881/* Same as ada_get_decoded_value, but with the given TYPE.
882 Because there is no associated actual value for this type,
883 the resulting type might be a best-effort approximation in
884 the case of dynamic types. */
885
886struct type *
887ada_get_decoded_type (struct type *type)
888{
889 type = to_static_fixed_type (type);
890 if (ada_is_constrained_packed_array_type (type))
891 type = ada_coerce_to_simple_array_type (type);
892 return type;
893}
894
4c4b4cd2 895\f
76a01679 896
4c4b4cd2 897 /* Language Selection */
14f9c5c9
AS
898
899/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 900 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 901
14f9c5c9 902enum language
ccefe4c4 903ada_update_initial_language (enum language lang)
14f9c5c9 904{
d2e4a39e 905 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 906 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 907 return language_ada;
14f9c5c9
AS
908
909 return lang;
910}
96d887e8
PH
911
912/* If the main procedure is written in Ada, then return its name.
913 The result is good until the next call. Return NULL if the main
914 procedure doesn't appear to be in Ada. */
915
916char *
917ada_main_name (void)
918{
3b7344d5 919 struct bound_minimal_symbol msym;
e83e4e24 920 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 921
96d887e8
PH
922 /* For Ada, the name of the main procedure is stored in a specific
923 string constant, generated by the binder. Look for that symbol,
924 extract its address, and then read that string. If we didn't find
925 that string, then most probably the main procedure is not written
926 in Ada. */
927 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
928
3b7344d5 929 if (msym.minsym != NULL)
96d887e8 930 {
f9bc20b9
JB
931 CORE_ADDR main_program_name_addr;
932 int err_code;
933
77e371c0 934 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 935 if (main_program_name_addr == 0)
323e0a4a 936 error (_("Invalid address for Ada main program name."));
96d887e8 937
f9bc20b9
JB
938 target_read_string (main_program_name_addr, &main_program_name,
939 1024, &err_code);
940
941 if (err_code != 0)
942 return NULL;
e83e4e24 943 return main_program_name.get ();
96d887e8
PH
944 }
945
946 /* The main procedure doesn't seem to be in Ada. */
947 return NULL;
948}
14f9c5c9 949\f
4c4b4cd2 950 /* Symbols */
d2e4a39e 951
4c4b4cd2
PH
952/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
953 of NULLs. */
14f9c5c9 954
d2e4a39e
AS
955const struct ada_opname_map ada_opname_table[] = {
956 {"Oadd", "\"+\"", BINOP_ADD},
957 {"Osubtract", "\"-\"", BINOP_SUB},
958 {"Omultiply", "\"*\"", BINOP_MUL},
959 {"Odivide", "\"/\"", BINOP_DIV},
960 {"Omod", "\"mod\"", BINOP_MOD},
961 {"Orem", "\"rem\"", BINOP_REM},
962 {"Oexpon", "\"**\"", BINOP_EXP},
963 {"Olt", "\"<\"", BINOP_LESS},
964 {"Ole", "\"<=\"", BINOP_LEQ},
965 {"Ogt", "\">\"", BINOP_GTR},
966 {"Oge", "\">=\"", BINOP_GEQ},
967 {"Oeq", "\"=\"", BINOP_EQUAL},
968 {"One", "\"/=\"", BINOP_NOTEQUAL},
969 {"Oand", "\"and\"", BINOP_BITWISE_AND},
970 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
971 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
972 {"Oconcat", "\"&\"", BINOP_CONCAT},
973 {"Oabs", "\"abs\"", UNOP_ABS},
974 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
975 {"Oadd", "\"+\"", UNOP_PLUS},
976 {"Osubtract", "\"-\"", UNOP_NEG},
977 {NULL, NULL}
14f9c5c9
AS
978};
979
b5ec771e
PA
980/* The "encoded" form of DECODED, according to GNAT conventions. The
981 result is valid until the next call to ada_encode. If
982 THROW_ERRORS, throw an error if invalid operator name is found.
983 Otherwise, return NULL in that case. */
4c4b4cd2 984
b5ec771e
PA
985static char *
986ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 987{
4c4b4cd2
PH
988 static char *encoding_buffer = NULL;
989 static size_t encoding_buffer_size = 0;
d2e4a39e 990 const char *p;
14f9c5c9 991 int k;
d2e4a39e 992
4c4b4cd2 993 if (decoded == NULL)
14f9c5c9
AS
994 return NULL;
995
4c4b4cd2
PH
996 GROW_VECT (encoding_buffer, encoding_buffer_size,
997 2 * strlen (decoded) + 10);
14f9c5c9
AS
998
999 k = 0;
4c4b4cd2 1000 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 1001 {
cdc7bb92 1002 if (*p == '.')
4c4b4cd2
PH
1003 {
1004 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1005 k += 2;
1006 }
14f9c5c9 1007 else if (*p == '"')
4c4b4cd2
PH
1008 {
1009 const struct ada_opname_map *mapping;
1010
1011 for (mapping = ada_opname_table;
1265e4aa 1012 mapping->encoded != NULL
61012eef 1013 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1014 ;
1015 if (mapping->encoded == NULL)
b5ec771e
PA
1016 {
1017 if (throw_errors)
1018 error (_("invalid Ada operator name: %s"), p);
1019 else
1020 return NULL;
1021 }
4c4b4cd2
PH
1022 strcpy (encoding_buffer + k, mapping->encoded);
1023 k += strlen (mapping->encoded);
1024 break;
1025 }
d2e4a39e 1026 else
4c4b4cd2
PH
1027 {
1028 encoding_buffer[k] = *p;
1029 k += 1;
1030 }
14f9c5c9
AS
1031 }
1032
4c4b4cd2
PH
1033 encoding_buffer[k] = '\0';
1034 return encoding_buffer;
14f9c5c9
AS
1035}
1036
b5ec771e
PA
1037/* The "encoded" form of DECODED, according to GNAT conventions.
1038 The result is valid until the next call to ada_encode. */
1039
1040char *
1041ada_encode (const char *decoded)
1042{
1043 return ada_encode_1 (decoded, true);
1044}
1045
14f9c5c9 1046/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1047 quotes, unfolded, but with the quotes stripped away. Result good
1048 to next call. */
1049
d2e4a39e
AS
1050char *
1051ada_fold_name (const char *name)
14f9c5c9 1052{
d2e4a39e 1053 static char *fold_buffer = NULL;
14f9c5c9
AS
1054 static size_t fold_buffer_size = 0;
1055
1056 int len = strlen (name);
d2e4a39e 1057 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1058
1059 if (name[0] == '\'')
1060 {
d2e4a39e
AS
1061 strncpy (fold_buffer, name + 1, len - 2);
1062 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1063 }
1064 else
1065 {
1066 int i;
5b4ee69b 1067
14f9c5c9 1068 for (i = 0; i <= len; i += 1)
4c4b4cd2 1069 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1070 }
1071
1072 return fold_buffer;
1073}
1074
529cad9c
PH
1075/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1076
1077static int
1078is_lower_alphanum (const char c)
1079{
1080 return (isdigit (c) || (isalpha (c) && islower (c)));
1081}
1082
c90092fe
JB
1083/* ENCODED is the linkage name of a symbol and LEN contains its length.
1084 This function saves in LEN the length of that same symbol name but
1085 without either of these suffixes:
29480c32
JB
1086 . .{DIGIT}+
1087 . ${DIGIT}+
1088 . ___{DIGIT}+
1089 . __{DIGIT}+.
c90092fe 1090
29480c32
JB
1091 These are suffixes introduced by the compiler for entities such as
1092 nested subprogram for instance, in order to avoid name clashes.
1093 They do not serve any purpose for the debugger. */
1094
1095static void
1096ada_remove_trailing_digits (const char *encoded, int *len)
1097{
1098 if (*len > 1 && isdigit (encoded[*len - 1]))
1099 {
1100 int i = *len - 2;
5b4ee69b 1101
29480c32
JB
1102 while (i > 0 && isdigit (encoded[i]))
1103 i--;
1104 if (i >= 0 && encoded[i] == '.')
1105 *len = i;
1106 else if (i >= 0 && encoded[i] == '$')
1107 *len = i;
61012eef 1108 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1109 *len = i - 2;
61012eef 1110 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1111 *len = i - 1;
1112 }
1113}
1114
1115/* Remove the suffix introduced by the compiler for protected object
1116 subprograms. */
1117
1118static void
1119ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1120{
1121 /* Remove trailing N. */
1122
1123 /* Protected entry subprograms are broken into two
1124 separate subprograms: The first one is unprotected, and has
1125 a 'N' suffix; the second is the protected version, and has
0963b4bd 1126 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1127 the protection. Since the P subprograms are internally generated,
1128 we leave these names undecoded, giving the user a clue that this
1129 entity is internal. */
1130
1131 if (*len > 1
1132 && encoded[*len - 1] == 'N'
1133 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1134 *len = *len - 1;
1135}
1136
69fadcdf
JB
1137/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1138
1139static void
1140ada_remove_Xbn_suffix (const char *encoded, int *len)
1141{
1142 int i = *len - 1;
1143
1144 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1145 i--;
1146
1147 if (encoded[i] != 'X')
1148 return;
1149
1150 if (i == 0)
1151 return;
1152
1153 if (isalnum (encoded[i-1]))
1154 *len = i;
1155}
1156
29480c32
JB
1157/* If ENCODED follows the GNAT entity encoding conventions, then return
1158 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1159 replaced by ENCODED.
14f9c5c9 1160
4c4b4cd2 1161 The resulting string is valid until the next call of ada_decode.
29480c32 1162 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1163 is returned. */
1164
1165const char *
1166ada_decode (const char *encoded)
14f9c5c9
AS
1167{
1168 int i, j;
1169 int len0;
d2e4a39e 1170 const char *p;
4c4b4cd2 1171 char *decoded;
14f9c5c9 1172 int at_start_name;
4c4b4cd2
PH
1173 static char *decoding_buffer = NULL;
1174 static size_t decoding_buffer_size = 0;
d2e4a39e 1175
0d81f350
JG
1176 /* With function descriptors on PPC64, the value of a symbol named
1177 ".FN", if it exists, is the entry point of the function "FN". */
1178 if (encoded[0] == '.')
1179 encoded += 1;
1180
29480c32
JB
1181 /* The name of the Ada main procedure starts with "_ada_".
1182 This prefix is not part of the decoded name, so skip this part
1183 if we see this prefix. */
61012eef 1184 if (startswith (encoded, "_ada_"))
4c4b4cd2 1185 encoded += 5;
14f9c5c9 1186
29480c32
JB
1187 /* If the name starts with '_', then it is not a properly encoded
1188 name, so do not attempt to decode it. Similarly, if the name
1189 starts with '<', the name should not be decoded. */
4c4b4cd2 1190 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1191 goto Suppress;
1192
4c4b4cd2 1193 len0 = strlen (encoded);
4c4b4cd2 1194
29480c32
JB
1195 ada_remove_trailing_digits (encoded, &len0);
1196 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1197
4c4b4cd2
PH
1198 /* Remove the ___X.* suffix if present. Do not forget to verify that
1199 the suffix is located before the current "end" of ENCODED. We want
1200 to avoid re-matching parts of ENCODED that have previously been
1201 marked as discarded (by decrementing LEN0). */
1202 p = strstr (encoded, "___");
1203 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1204 {
1205 if (p[3] == 'X')
4c4b4cd2 1206 len0 = p - encoded;
14f9c5c9 1207 else
4c4b4cd2 1208 goto Suppress;
14f9c5c9 1209 }
4c4b4cd2 1210
29480c32
JB
1211 /* Remove any trailing TKB suffix. It tells us that this symbol
1212 is for the body of a task, but that information does not actually
1213 appear in the decoded name. */
1214
61012eef 1215 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1216 len0 -= 3;
76a01679 1217
a10967fa
JB
1218 /* Remove any trailing TB suffix. The TB suffix is slightly different
1219 from the TKB suffix because it is used for non-anonymous task
1220 bodies. */
1221
61012eef 1222 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1223 len0 -= 2;
1224
29480c32
JB
1225 /* Remove trailing "B" suffixes. */
1226 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1227
61012eef 1228 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1229 len0 -= 1;
1230
4c4b4cd2 1231 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1232
4c4b4cd2
PH
1233 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1234 decoded = decoding_buffer;
14f9c5c9 1235
29480c32
JB
1236 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1237
4c4b4cd2 1238 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1239 {
4c4b4cd2
PH
1240 i = len0 - 2;
1241 while ((i >= 0 && isdigit (encoded[i]))
1242 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1243 i -= 1;
1244 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1245 len0 = i - 1;
1246 else if (encoded[i] == '$')
1247 len0 = i;
d2e4a39e 1248 }
14f9c5c9 1249
29480c32
JB
1250 /* The first few characters that are not alphabetic are not part
1251 of any encoding we use, so we can copy them over verbatim. */
1252
4c4b4cd2
PH
1253 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1254 decoded[j] = encoded[i];
14f9c5c9
AS
1255
1256 at_start_name = 1;
1257 while (i < len0)
1258 {
29480c32 1259 /* Is this a symbol function? */
4c4b4cd2
PH
1260 if (at_start_name && encoded[i] == 'O')
1261 {
1262 int k;
5b4ee69b 1263
4c4b4cd2
PH
1264 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1265 {
1266 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1267 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1268 op_len - 1) == 0)
1269 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1270 {
1271 strcpy (decoded + j, ada_opname_table[k].decoded);
1272 at_start_name = 0;
1273 i += op_len;
1274 j += strlen (ada_opname_table[k].decoded);
1275 break;
1276 }
1277 }
1278 if (ada_opname_table[k].encoded != NULL)
1279 continue;
1280 }
14f9c5c9
AS
1281 at_start_name = 0;
1282
529cad9c
PH
1283 /* Replace "TK__" with "__", which will eventually be translated
1284 into "." (just below). */
1285
61012eef 1286 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1287 i += 2;
529cad9c 1288
29480c32
JB
1289 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1290 be translated into "." (just below). These are internal names
1291 generated for anonymous blocks inside which our symbol is nested. */
1292
1293 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1294 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1295 && isdigit (encoded [i+4]))
1296 {
1297 int k = i + 5;
1298
1299 while (k < len0 && isdigit (encoded[k]))
1300 k++; /* Skip any extra digit. */
1301
1302 /* Double-check that the "__B_{DIGITS}+" sequence we found
1303 is indeed followed by "__". */
1304 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1305 i = k;
1306 }
1307
529cad9c
PH
1308 /* Remove _E{DIGITS}+[sb] */
1309
1310 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1311 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1312 one implements the actual entry code, and has a suffix following
1313 the convention above; the second one implements the barrier and
1314 uses the same convention as above, except that the 'E' is replaced
1315 by a 'B'.
1316
1317 Just as above, we do not decode the name of barrier functions
1318 to give the user a clue that the code he is debugging has been
1319 internally generated. */
1320
1321 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1322 && isdigit (encoded[i+2]))
1323 {
1324 int k = i + 3;
1325
1326 while (k < len0 && isdigit (encoded[k]))
1327 k++;
1328
1329 if (k < len0
1330 && (encoded[k] == 'b' || encoded[k] == 's'))
1331 {
1332 k++;
1333 /* Just as an extra precaution, make sure that if this
1334 suffix is followed by anything else, it is a '_'.
1335 Otherwise, we matched this sequence by accident. */
1336 if (k == len0
1337 || (k < len0 && encoded[k] == '_'))
1338 i = k;
1339 }
1340 }
1341
1342 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1343 the GNAT front-end in protected object subprograms. */
1344
1345 if (i < len0 + 3
1346 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1347 {
1348 /* Backtrack a bit up until we reach either the begining of
1349 the encoded name, or "__". Make sure that we only find
1350 digits or lowercase characters. */
1351 const char *ptr = encoded + i - 1;
1352
1353 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1354 ptr--;
1355 if (ptr < encoded
1356 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1357 i++;
1358 }
1359
4c4b4cd2
PH
1360 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1361 {
29480c32
JB
1362 /* This is a X[bn]* sequence not separated from the previous
1363 part of the name with a non-alpha-numeric character (in other
1364 words, immediately following an alpha-numeric character), then
1365 verify that it is placed at the end of the encoded name. If
1366 not, then the encoding is not valid and we should abort the
1367 decoding. Otherwise, just skip it, it is used in body-nested
1368 package names. */
4c4b4cd2
PH
1369 do
1370 i += 1;
1371 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1372 if (i < len0)
1373 goto Suppress;
1374 }
cdc7bb92 1375 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1376 {
29480c32 1377 /* Replace '__' by '.'. */
4c4b4cd2
PH
1378 decoded[j] = '.';
1379 at_start_name = 1;
1380 i += 2;
1381 j += 1;
1382 }
14f9c5c9 1383 else
4c4b4cd2 1384 {
29480c32
JB
1385 /* It's a character part of the decoded name, so just copy it
1386 over. */
4c4b4cd2
PH
1387 decoded[j] = encoded[i];
1388 i += 1;
1389 j += 1;
1390 }
14f9c5c9 1391 }
4c4b4cd2 1392 decoded[j] = '\000';
14f9c5c9 1393
29480c32
JB
1394 /* Decoded names should never contain any uppercase character.
1395 Double-check this, and abort the decoding if we find one. */
1396
4c4b4cd2
PH
1397 for (i = 0; decoded[i] != '\0'; i += 1)
1398 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1399 goto Suppress;
1400
4c4b4cd2
PH
1401 if (strcmp (decoded, encoded) == 0)
1402 return encoded;
1403 else
1404 return decoded;
14f9c5c9
AS
1405
1406Suppress:
4c4b4cd2
PH
1407 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1408 decoded = decoding_buffer;
1409 if (encoded[0] == '<')
1410 strcpy (decoded, encoded);
14f9c5c9 1411 else
88c15c34 1412 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1413 return decoded;
1414
1415}
1416
1417/* Table for keeping permanent unique copies of decoded names. Once
1418 allocated, names in this table are never released. While this is a
1419 storage leak, it should not be significant unless there are massive
1420 changes in the set of decoded names in successive versions of a
1421 symbol table loaded during a single session. */
1422static struct htab *decoded_names_store;
1423
1424/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1425 in the language-specific part of GSYMBOL, if it has not been
1426 previously computed. Tries to save the decoded name in the same
1427 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1428 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1429 GSYMBOL).
4c4b4cd2
PH
1430 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1431 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1432 when a decoded name is cached in it. */
4c4b4cd2 1433
45e6c716 1434const char *
f85f34ed 1435ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1436{
f85f34ed
TT
1437 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1438 const char **resultp =
615b3f62 1439 &gsymbol->language_specific.demangled_name;
5b4ee69b 1440
f85f34ed 1441 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1442 {
1443 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1444 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1445
f85f34ed 1446 gsymbol->ada_mangled = 1;
5b4ee69b 1447
f85f34ed 1448 if (obstack != NULL)
224c3ddb
SM
1449 *resultp
1450 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1451 else
76a01679 1452 {
f85f34ed
TT
1453 /* Sometimes, we can't find a corresponding objfile, in
1454 which case, we put the result on the heap. Since we only
1455 decode when needed, we hope this usually does not cause a
1456 significant memory leak (FIXME). */
1457
76a01679
JB
1458 char **slot = (char **) htab_find_slot (decoded_names_store,
1459 decoded, INSERT);
5b4ee69b 1460
76a01679
JB
1461 if (*slot == NULL)
1462 *slot = xstrdup (decoded);
1463 *resultp = *slot;
1464 }
4c4b4cd2 1465 }
14f9c5c9 1466
4c4b4cd2
PH
1467 return *resultp;
1468}
76a01679 1469
2c0b251b 1470static char *
76a01679 1471ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1472{
1473 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1474}
1475
8b302db8
TT
1476/* Implement la_sniff_from_mangled_name for Ada. */
1477
1478static int
1479ada_sniff_from_mangled_name (const char *mangled, char **out)
1480{
1481 const char *demangled = ada_decode (mangled);
1482
1483 *out = NULL;
1484
1485 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1486 {
1487 /* Set the gsymbol language to Ada, but still return 0.
1488 Two reasons for that:
1489
1490 1. For Ada, we prefer computing the symbol's decoded name
1491 on the fly rather than pre-compute it, in order to save
1492 memory (Ada projects are typically very large).
1493
1494 2. There are some areas in the definition of the GNAT
1495 encoding where, with a bit of bad luck, we might be able
1496 to decode a non-Ada symbol, generating an incorrect
1497 demangled name (Eg: names ending with "TB" for instance
1498 are identified as task bodies and so stripped from
1499 the decoded name returned).
1500
1501 Returning 1, here, but not setting *DEMANGLED, helps us get a
1502 little bit of the best of both worlds. Because we're last,
1503 we should not affect any of the other languages that were
1504 able to demangle the symbol before us; we get to correctly
1505 tag Ada symbols as such; and even if we incorrectly tagged a
1506 non-Ada symbol, which should be rare, any routing through the
1507 Ada language should be transparent (Ada tries to behave much
1508 like C/C++ with non-Ada symbols). */
1509 return 1;
1510 }
1511
1512 return 0;
1513}
1514
14f9c5c9 1515\f
d2e4a39e 1516
4c4b4cd2 1517 /* Arrays */
14f9c5c9 1518
28c85d6c
JB
1519/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1520 generated by the GNAT compiler to describe the index type used
1521 for each dimension of an array, check whether it follows the latest
1522 known encoding. If not, fix it up to conform to the latest encoding.
1523 Otherwise, do nothing. This function also does nothing if
1524 INDEX_DESC_TYPE is NULL.
1525
1526 The GNAT encoding used to describle the array index type evolved a bit.
1527 Initially, the information would be provided through the name of each
1528 field of the structure type only, while the type of these fields was
1529 described as unspecified and irrelevant. The debugger was then expected
1530 to perform a global type lookup using the name of that field in order
1531 to get access to the full index type description. Because these global
1532 lookups can be very expensive, the encoding was later enhanced to make
1533 the global lookup unnecessary by defining the field type as being
1534 the full index type description.
1535
1536 The purpose of this routine is to allow us to support older versions
1537 of the compiler by detecting the use of the older encoding, and by
1538 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1539 we essentially replace each field's meaningless type by the associated
1540 index subtype). */
1541
1542void
1543ada_fixup_array_indexes_type (struct type *index_desc_type)
1544{
1545 int i;
1546
1547 if (index_desc_type == NULL)
1548 return;
1549 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1550
1551 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1552 to check one field only, no need to check them all). If not, return
1553 now.
1554
1555 If our INDEX_DESC_TYPE was generated using the older encoding,
1556 the field type should be a meaningless integer type whose name
1557 is not equal to the field name. */
1558 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1559 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1560 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1561 return;
1562
1563 /* Fixup each field of INDEX_DESC_TYPE. */
1564 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1565 {
0d5cff50 1566 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1567 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1568
1569 if (raw_type)
1570 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1571 }
1572}
1573
4c4b4cd2 1574/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1575
a121b7c1 1576static const char *bound_name[] = {
d2e4a39e 1577 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1578 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1579};
1580
1581/* Maximum number of array dimensions we are prepared to handle. */
1582
4c4b4cd2 1583#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1584
14f9c5c9 1585
4c4b4cd2
PH
1586/* The desc_* routines return primitive portions of array descriptors
1587 (fat pointers). */
14f9c5c9
AS
1588
1589/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1590 level of indirection, if needed. */
1591
d2e4a39e
AS
1592static struct type *
1593desc_base_type (struct type *type)
14f9c5c9
AS
1594{
1595 if (type == NULL)
1596 return NULL;
61ee279c 1597 type = ada_check_typedef (type);
720d1a40
JB
1598 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1599 type = ada_typedef_target_type (type);
1600
1265e4aa
JB
1601 if (type != NULL
1602 && (TYPE_CODE (type) == TYPE_CODE_PTR
1603 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1604 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1605 else
1606 return type;
1607}
1608
4c4b4cd2
PH
1609/* True iff TYPE indicates a "thin" array pointer type. */
1610
14f9c5c9 1611static int
d2e4a39e 1612is_thin_pntr (struct type *type)
14f9c5c9 1613{
d2e4a39e 1614 return
14f9c5c9
AS
1615 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1616 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1617}
1618
4c4b4cd2
PH
1619/* The descriptor type for thin pointer type TYPE. */
1620
d2e4a39e
AS
1621static struct type *
1622thin_descriptor_type (struct type *type)
14f9c5c9 1623{
d2e4a39e 1624 struct type *base_type = desc_base_type (type);
5b4ee69b 1625
14f9c5c9
AS
1626 if (base_type == NULL)
1627 return NULL;
1628 if (is_suffix (ada_type_name (base_type), "___XVE"))
1629 return base_type;
d2e4a39e 1630 else
14f9c5c9 1631 {
d2e4a39e 1632 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1633
14f9c5c9 1634 if (alt_type == NULL)
4c4b4cd2 1635 return base_type;
14f9c5c9 1636 else
4c4b4cd2 1637 return alt_type;
14f9c5c9
AS
1638 }
1639}
1640
4c4b4cd2
PH
1641/* A pointer to the array data for thin-pointer value VAL. */
1642
d2e4a39e
AS
1643static struct value *
1644thin_data_pntr (struct value *val)
14f9c5c9 1645{
828292f2 1646 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1647 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1648
556bdfd4
UW
1649 data_type = lookup_pointer_type (data_type);
1650
14f9c5c9 1651 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1652 return value_cast (data_type, value_copy (val));
d2e4a39e 1653 else
42ae5230 1654 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1655}
1656
4c4b4cd2
PH
1657/* True iff TYPE indicates a "thick" array pointer type. */
1658
14f9c5c9 1659static int
d2e4a39e 1660is_thick_pntr (struct type *type)
14f9c5c9
AS
1661{
1662 type = desc_base_type (type);
1663 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1664 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1665}
1666
4c4b4cd2
PH
1667/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1668 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1669
d2e4a39e
AS
1670static struct type *
1671desc_bounds_type (struct type *type)
14f9c5c9 1672{
d2e4a39e 1673 struct type *r;
14f9c5c9
AS
1674
1675 type = desc_base_type (type);
1676
1677 if (type == NULL)
1678 return NULL;
1679 else if (is_thin_pntr (type))
1680 {
1681 type = thin_descriptor_type (type);
1682 if (type == NULL)
4c4b4cd2 1683 return NULL;
14f9c5c9
AS
1684 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1685 if (r != NULL)
61ee279c 1686 return ada_check_typedef (r);
14f9c5c9
AS
1687 }
1688 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1689 {
1690 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1691 if (r != NULL)
61ee279c 1692 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1693 }
1694 return NULL;
1695}
1696
1697/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1698 one, a pointer to its bounds data. Otherwise NULL. */
1699
d2e4a39e
AS
1700static struct value *
1701desc_bounds (struct value *arr)
14f9c5c9 1702{
df407dfe 1703 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1704
d2e4a39e 1705 if (is_thin_pntr (type))
14f9c5c9 1706 {
d2e4a39e 1707 struct type *bounds_type =
4c4b4cd2 1708 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1709 LONGEST addr;
1710
4cdfadb1 1711 if (bounds_type == NULL)
323e0a4a 1712 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1713
1714 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1715 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1716 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1717 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1718 addr = value_as_long (arr);
d2e4a39e 1719 else
42ae5230 1720 addr = value_address (arr);
14f9c5c9 1721
d2e4a39e 1722 return
4c4b4cd2
PH
1723 value_from_longest (lookup_pointer_type (bounds_type),
1724 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1725 }
1726
1727 else if (is_thick_pntr (type))
05e522ef
JB
1728 {
1729 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1730 _("Bad GNAT array descriptor"));
1731 struct type *p_bounds_type = value_type (p_bounds);
1732
1733 if (p_bounds_type
1734 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1735 {
1736 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1737
1738 if (TYPE_STUB (target_type))
1739 p_bounds = value_cast (lookup_pointer_type
1740 (ada_check_typedef (target_type)),
1741 p_bounds);
1742 }
1743 else
1744 error (_("Bad GNAT array descriptor"));
1745
1746 return p_bounds;
1747 }
14f9c5c9
AS
1748 else
1749 return NULL;
1750}
1751
4c4b4cd2
PH
1752/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1753 position of the field containing the address of the bounds data. */
1754
14f9c5c9 1755static int
d2e4a39e 1756fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1757{
1758 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1759}
1760
1761/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1762 size of the field containing the address of the bounds data. */
1763
14f9c5c9 1764static int
d2e4a39e 1765fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1766{
1767 type = desc_base_type (type);
1768
d2e4a39e 1769 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1770 return TYPE_FIELD_BITSIZE (type, 1);
1771 else
61ee279c 1772 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1773}
1774
4c4b4cd2 1775/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1776 pointer to one, the type of its array data (a array-with-no-bounds type);
1777 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1778 data. */
4c4b4cd2 1779
d2e4a39e 1780static struct type *
556bdfd4 1781desc_data_target_type (struct type *type)
14f9c5c9
AS
1782{
1783 type = desc_base_type (type);
1784
4c4b4cd2 1785 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1786 if (is_thin_pntr (type))
556bdfd4 1787 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1788 else if (is_thick_pntr (type))
556bdfd4
UW
1789 {
1790 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1791
1792 if (data_type
1793 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1794 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1795 }
1796
1797 return NULL;
14f9c5c9
AS
1798}
1799
1800/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1801 its array data. */
4c4b4cd2 1802
d2e4a39e
AS
1803static struct value *
1804desc_data (struct value *arr)
14f9c5c9 1805{
df407dfe 1806 struct type *type = value_type (arr);
5b4ee69b 1807
14f9c5c9
AS
1808 if (is_thin_pntr (type))
1809 return thin_data_pntr (arr);
1810 else if (is_thick_pntr (type))
d2e4a39e 1811 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1812 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1813 else
1814 return NULL;
1815}
1816
1817
1818/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1819 position of the field containing the address of the data. */
1820
14f9c5c9 1821static int
d2e4a39e 1822fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1823{
1824 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1825}
1826
1827/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1828 size of the field containing the address of the data. */
1829
14f9c5c9 1830static int
d2e4a39e 1831fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1832{
1833 type = desc_base_type (type);
1834
1835 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1836 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1837 else
14f9c5c9
AS
1838 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1839}
1840
4c4b4cd2 1841/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1842 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1843 bound, if WHICH is 1. The first bound is I=1. */
1844
d2e4a39e
AS
1845static struct value *
1846desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1847{
d2e4a39e 1848 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1849 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1850}
1851
1852/* If BOUNDS is an array-bounds structure type, return the bit position
1853 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1854 bound, if WHICH is 1. The first bound is I=1. */
1855
14f9c5c9 1856static int
d2e4a39e 1857desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1858{
d2e4a39e 1859 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1860}
1861
1862/* If BOUNDS is an array-bounds structure type, return the bit field size
1863 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1864 bound, if WHICH is 1. The first bound is I=1. */
1865
76a01679 1866static int
d2e4a39e 1867desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1868{
1869 type = desc_base_type (type);
1870
d2e4a39e
AS
1871 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1872 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1873 else
1874 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1875}
1876
1877/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1878 Ith bound (numbering from 1). Otherwise, NULL. */
1879
d2e4a39e
AS
1880static struct type *
1881desc_index_type (struct type *type, int i)
14f9c5c9
AS
1882{
1883 type = desc_base_type (type);
1884
1885 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1886 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1887 else
14f9c5c9
AS
1888 return NULL;
1889}
1890
4c4b4cd2
PH
1891/* The number of index positions in the array-bounds type TYPE.
1892 Return 0 if TYPE is NULL. */
1893
14f9c5c9 1894static int
d2e4a39e 1895desc_arity (struct type *type)
14f9c5c9
AS
1896{
1897 type = desc_base_type (type);
1898
1899 if (type != NULL)
1900 return TYPE_NFIELDS (type) / 2;
1901 return 0;
1902}
1903
4c4b4cd2
PH
1904/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1905 an array descriptor type (representing an unconstrained array
1906 type). */
1907
76a01679
JB
1908static int
1909ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1910{
1911 if (type == NULL)
1912 return 0;
61ee279c 1913 type = ada_check_typedef (type);
4c4b4cd2 1914 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1915 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1916}
1917
52ce6436 1918/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1919 * to one. */
52ce6436 1920
2c0b251b 1921static int
52ce6436
PH
1922ada_is_array_type (struct type *type)
1923{
1924 while (type != NULL
1925 && (TYPE_CODE (type) == TYPE_CODE_PTR
1926 || TYPE_CODE (type) == TYPE_CODE_REF))
1927 type = TYPE_TARGET_TYPE (type);
1928 return ada_is_direct_array_type (type);
1929}
1930
4c4b4cd2 1931/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1932
14f9c5c9 1933int
4c4b4cd2 1934ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1935{
1936 if (type == NULL)
1937 return 0;
61ee279c 1938 type = ada_check_typedef (type);
14f9c5c9 1939 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1940 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1941 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1942 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1943}
1944
4c4b4cd2
PH
1945/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1946
14f9c5c9 1947int
4c4b4cd2 1948ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1949{
556bdfd4 1950 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1951
1952 if (type == NULL)
1953 return 0;
61ee279c 1954 type = ada_check_typedef (type);
556bdfd4
UW
1955 return (data_type != NULL
1956 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1957 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1958}
1959
1960/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1961 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1962 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1963 is still needed. */
1964
14f9c5c9 1965int
ebf56fd3 1966ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1967{
d2e4a39e 1968 return
14f9c5c9
AS
1969 type != NULL
1970 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1971 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1972 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1973 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1974}
1975
1976
4c4b4cd2 1977/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1978 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1979 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1980 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1981 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1982 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1983 a descriptor. */
d2e4a39e
AS
1984struct type *
1985ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1986{
ad82864c
JB
1987 if (ada_is_constrained_packed_array_type (value_type (arr)))
1988 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1989
df407dfe
AC
1990 if (!ada_is_array_descriptor_type (value_type (arr)))
1991 return value_type (arr);
d2e4a39e
AS
1992
1993 if (!bounds)
ad82864c
JB
1994 {
1995 struct type *array_type =
1996 ada_check_typedef (desc_data_target_type (value_type (arr)));
1997
1998 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1999 TYPE_FIELD_BITSIZE (array_type, 0) =
2000 decode_packed_array_bitsize (value_type (arr));
2001
2002 return array_type;
2003 }
14f9c5c9
AS
2004 else
2005 {
d2e4a39e 2006 struct type *elt_type;
14f9c5c9 2007 int arity;
d2e4a39e 2008 struct value *descriptor;
14f9c5c9 2009
df407dfe
AC
2010 elt_type = ada_array_element_type (value_type (arr), -1);
2011 arity = ada_array_arity (value_type (arr));
14f9c5c9 2012
d2e4a39e 2013 if (elt_type == NULL || arity == 0)
df407dfe 2014 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2015
2016 descriptor = desc_bounds (arr);
d2e4a39e 2017 if (value_as_long (descriptor) == 0)
4c4b4cd2 2018 return NULL;
d2e4a39e 2019 while (arity > 0)
4c4b4cd2 2020 {
e9bb382b
UW
2021 struct type *range_type = alloc_type_copy (value_type (arr));
2022 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2023 struct value *low = desc_one_bound (descriptor, arity, 0);
2024 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2025
5b4ee69b 2026 arity -= 1;
0c9c3474
SA
2027 create_static_range_type (range_type, value_type (low),
2028 longest_to_int (value_as_long (low)),
2029 longest_to_int (value_as_long (high)));
4c4b4cd2 2030 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2031
2032 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2033 {
2034 /* We need to store the element packed bitsize, as well as
2035 recompute the array size, because it was previously
2036 computed based on the unpacked element size. */
2037 LONGEST lo = value_as_long (low);
2038 LONGEST hi = value_as_long (high);
2039
2040 TYPE_FIELD_BITSIZE (elt_type, 0) =
2041 decode_packed_array_bitsize (value_type (arr));
2042 /* If the array has no element, then the size is already
2043 zero, and does not need to be recomputed. */
2044 if (lo < hi)
2045 {
2046 int array_bitsize =
2047 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2048
2049 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2050 }
2051 }
4c4b4cd2 2052 }
14f9c5c9
AS
2053
2054 return lookup_pointer_type (elt_type);
2055 }
2056}
2057
2058/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2059 Otherwise, returns either a standard GDB array with bounds set
2060 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2061 GDB array. Returns NULL if ARR is a null fat pointer. */
2062
d2e4a39e
AS
2063struct value *
2064ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2065{
df407dfe 2066 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2067 {
d2e4a39e 2068 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2069
14f9c5c9 2070 if (arrType == NULL)
4c4b4cd2 2071 return NULL;
14f9c5c9
AS
2072 return value_cast (arrType, value_copy (desc_data (arr)));
2073 }
ad82864c
JB
2074 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2075 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2076 else
2077 return arr;
2078}
2079
2080/* If ARR does not represent an array, returns ARR unchanged.
2081 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2082 be ARR itself if it already is in the proper form). */
2083
720d1a40 2084struct value *
d2e4a39e 2085ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2086{
df407dfe 2087 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2088 {
d2e4a39e 2089 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2090
14f9c5c9 2091 if (arrVal == NULL)
323e0a4a 2092 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2093 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2094 return value_ind (arrVal);
2095 }
ad82864c
JB
2096 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2097 return decode_constrained_packed_array (arr);
d2e4a39e 2098 else
14f9c5c9
AS
2099 return arr;
2100}
2101
2102/* If TYPE represents a GNAT array type, return it translated to an
2103 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2104 packing). For other types, is the identity. */
2105
d2e4a39e
AS
2106struct type *
2107ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2108{
ad82864c
JB
2109 if (ada_is_constrained_packed_array_type (type))
2110 return decode_constrained_packed_array_type (type);
17280b9f
UW
2111
2112 if (ada_is_array_descriptor_type (type))
556bdfd4 2113 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2114
2115 return type;
14f9c5c9
AS
2116}
2117
4c4b4cd2
PH
2118/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2119
ad82864c
JB
2120static int
2121ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2122{
2123 if (type == NULL)
2124 return 0;
4c4b4cd2 2125 type = desc_base_type (type);
61ee279c 2126 type = ada_check_typedef (type);
d2e4a39e 2127 return
14f9c5c9
AS
2128 ada_type_name (type) != NULL
2129 && strstr (ada_type_name (type), "___XP") != NULL;
2130}
2131
ad82864c
JB
2132/* Non-zero iff TYPE represents a standard GNAT constrained
2133 packed-array type. */
2134
2135int
2136ada_is_constrained_packed_array_type (struct type *type)
2137{
2138 return ada_is_packed_array_type (type)
2139 && !ada_is_array_descriptor_type (type);
2140}
2141
2142/* Non-zero iff TYPE represents an array descriptor for a
2143 unconstrained packed-array type. */
2144
2145static int
2146ada_is_unconstrained_packed_array_type (struct type *type)
2147{
2148 return ada_is_packed_array_type (type)
2149 && ada_is_array_descriptor_type (type);
2150}
2151
2152/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2153 return the size of its elements in bits. */
2154
2155static long
2156decode_packed_array_bitsize (struct type *type)
2157{
0d5cff50
DE
2158 const char *raw_name;
2159 const char *tail;
ad82864c
JB
2160 long bits;
2161
720d1a40
JB
2162 /* Access to arrays implemented as fat pointers are encoded as a typedef
2163 of the fat pointer type. We need the name of the fat pointer type
2164 to do the decoding, so strip the typedef layer. */
2165 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2166 type = ada_typedef_target_type (type);
2167
2168 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2169 if (!raw_name)
2170 raw_name = ada_type_name (desc_base_type (type));
2171
2172 if (!raw_name)
2173 return 0;
2174
2175 tail = strstr (raw_name, "___XP");
720d1a40 2176 gdb_assert (tail != NULL);
ad82864c
JB
2177
2178 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2179 {
2180 lim_warning
2181 (_("could not understand bit size information on packed array"));
2182 return 0;
2183 }
2184
2185 return bits;
2186}
2187
14f9c5c9
AS
2188/* Given that TYPE is a standard GDB array type with all bounds filled
2189 in, and that the element size of its ultimate scalar constituents
2190 (that is, either its elements, or, if it is an array of arrays, its
2191 elements' elements, etc.) is *ELT_BITS, return an identical type,
2192 but with the bit sizes of its elements (and those of any
2193 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2194 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2195 in bits.
2196
2197 Note that, for arrays whose index type has an XA encoding where
2198 a bound references a record discriminant, getting that discriminant,
2199 and therefore the actual value of that bound, is not possible
2200 because none of the given parameters gives us access to the record.
2201 This function assumes that it is OK in the context where it is being
2202 used to return an array whose bounds are still dynamic and where
2203 the length is arbitrary. */
4c4b4cd2 2204
d2e4a39e 2205static struct type *
ad82864c 2206constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2207{
d2e4a39e
AS
2208 struct type *new_elt_type;
2209 struct type *new_type;
99b1c762
JB
2210 struct type *index_type_desc;
2211 struct type *index_type;
14f9c5c9
AS
2212 LONGEST low_bound, high_bound;
2213
61ee279c 2214 type = ada_check_typedef (type);
14f9c5c9
AS
2215 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2216 return type;
2217
99b1c762
JB
2218 index_type_desc = ada_find_parallel_type (type, "___XA");
2219 if (index_type_desc)
2220 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2221 NULL);
2222 else
2223 index_type = TYPE_INDEX_TYPE (type);
2224
e9bb382b 2225 new_type = alloc_type_copy (type);
ad82864c
JB
2226 new_elt_type =
2227 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2228 elt_bits);
99b1c762 2229 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2230 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2231 TYPE_NAME (new_type) = ada_type_name (type);
2232
4a46959e
JB
2233 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2234 && is_dynamic_type (check_typedef (index_type)))
2235 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2236 low_bound = high_bound = 0;
2237 if (high_bound < low_bound)
2238 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2239 else
14f9c5c9
AS
2240 {
2241 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2242 TYPE_LENGTH (new_type) =
4c4b4cd2 2243 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2244 }
2245
876cecd0 2246 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2247 return new_type;
2248}
2249
ad82864c
JB
2250/* The array type encoded by TYPE, where
2251 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2252
d2e4a39e 2253static struct type *
ad82864c 2254decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2255{
0d5cff50 2256 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2257 char *name;
0d5cff50 2258 const char *tail;
d2e4a39e 2259 struct type *shadow_type;
14f9c5c9 2260 long bits;
14f9c5c9 2261
727e3d2e
JB
2262 if (!raw_name)
2263 raw_name = ada_type_name (desc_base_type (type));
2264
2265 if (!raw_name)
2266 return NULL;
2267
2268 name = (char *) alloca (strlen (raw_name) + 1);
2269 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2270 type = desc_base_type (type);
2271
14f9c5c9
AS
2272 memcpy (name, raw_name, tail - raw_name);
2273 name[tail - raw_name] = '\000';
2274
b4ba55a1
JB
2275 shadow_type = ada_find_parallel_type_with_name (type, name);
2276
2277 if (shadow_type == NULL)
14f9c5c9 2278 {
323e0a4a 2279 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2280 return NULL;
2281 }
f168693b 2282 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2283
2284 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2285 {
0963b4bd
MS
2286 lim_warning (_("could not understand bounds "
2287 "information on packed array"));
14f9c5c9
AS
2288 return NULL;
2289 }
d2e4a39e 2290
ad82864c
JB
2291 bits = decode_packed_array_bitsize (type);
2292 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2293}
2294
ad82864c
JB
2295/* Given that ARR is a struct value *indicating a GNAT constrained packed
2296 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2297 standard GDB array type except that the BITSIZEs of the array
2298 target types are set to the number of bits in each element, and the
4c4b4cd2 2299 type length is set appropriately. */
14f9c5c9 2300
d2e4a39e 2301static struct value *
ad82864c 2302decode_constrained_packed_array (struct value *arr)
14f9c5c9 2303{
4c4b4cd2 2304 struct type *type;
14f9c5c9 2305
11aa919a
PMR
2306 /* If our value is a pointer, then dereference it. Likewise if
2307 the value is a reference. Make sure that this operation does not
2308 cause the target type to be fixed, as this would indirectly cause
2309 this array to be decoded. The rest of the routine assumes that
2310 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2311 and "value_ind" routines to perform the dereferencing, as opposed
2312 to using "ada_coerce_ref" or "ada_value_ind". */
2313 arr = coerce_ref (arr);
828292f2 2314 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2315 arr = value_ind (arr);
4c4b4cd2 2316
ad82864c 2317 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2318 if (type == NULL)
2319 {
323e0a4a 2320 error (_("can't unpack array"));
14f9c5c9
AS
2321 return NULL;
2322 }
61ee279c 2323
50810684 2324 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2325 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2326 {
2327 /* This is a (right-justified) modular type representing a packed
2328 array with no wrapper. In order to interpret the value through
2329 the (left-justified) packed array type we just built, we must
2330 first left-justify it. */
2331 int bit_size, bit_pos;
2332 ULONGEST mod;
2333
df407dfe 2334 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2335 bit_size = 0;
2336 while (mod > 0)
2337 {
2338 bit_size += 1;
2339 mod >>= 1;
2340 }
df407dfe 2341 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2342 arr = ada_value_primitive_packed_val (arr, NULL,
2343 bit_pos / HOST_CHAR_BIT,
2344 bit_pos % HOST_CHAR_BIT,
2345 bit_size,
2346 type);
2347 }
2348
4c4b4cd2 2349 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2350}
2351
2352
2353/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2354 given in IND. ARR must be a simple array. */
14f9c5c9 2355
d2e4a39e
AS
2356static struct value *
2357value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2358{
2359 int i;
2360 int bits, elt_off, bit_off;
2361 long elt_total_bit_offset;
d2e4a39e
AS
2362 struct type *elt_type;
2363 struct value *v;
14f9c5c9
AS
2364
2365 bits = 0;
2366 elt_total_bit_offset = 0;
df407dfe 2367 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2368 for (i = 0; i < arity; i += 1)
14f9c5c9 2369 {
d2e4a39e 2370 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2371 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2372 error
0963b4bd
MS
2373 (_("attempt to do packed indexing of "
2374 "something other than a packed array"));
14f9c5c9 2375 else
4c4b4cd2
PH
2376 {
2377 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2378 LONGEST lowerbound, upperbound;
2379 LONGEST idx;
2380
2381 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2382 {
323e0a4a 2383 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2384 lowerbound = upperbound = 0;
2385 }
2386
3cb382c9 2387 idx = pos_atr (ind[i]);
4c4b4cd2 2388 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2389 lim_warning (_("packed array index %ld out of bounds"),
2390 (long) idx);
4c4b4cd2
PH
2391 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2392 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2393 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2394 }
14f9c5c9
AS
2395 }
2396 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2397 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2398
2399 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2400 bits, elt_type);
14f9c5c9
AS
2401 return v;
2402}
2403
4c4b4cd2 2404/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2405
2406static int
d2e4a39e 2407has_negatives (struct type *type)
14f9c5c9 2408{
d2e4a39e
AS
2409 switch (TYPE_CODE (type))
2410 {
2411 default:
2412 return 0;
2413 case TYPE_CODE_INT:
2414 return !TYPE_UNSIGNED (type);
2415 case TYPE_CODE_RANGE:
2416 return TYPE_LOW_BOUND (type) < 0;
2417 }
14f9c5c9 2418}
d2e4a39e 2419
f93fca70 2420/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2421 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2422 the unpacked buffer.
14f9c5c9 2423
5b639dea
JB
2424 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2425 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2426
f93fca70
JB
2427 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2428 zero otherwise.
14f9c5c9 2429
f93fca70 2430 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2431
f93fca70
JB
2432 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2433
2434static void
2435ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2436 gdb_byte *unpacked, int unpacked_len,
2437 int is_big_endian, int is_signed_type,
2438 int is_scalar)
2439{
a1c95e6b
JB
2440 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2441 int src_idx; /* Index into the source area */
2442 int src_bytes_left; /* Number of source bytes left to process. */
2443 int srcBitsLeft; /* Number of source bits left to move */
2444 int unusedLS; /* Number of bits in next significant
2445 byte of source that are unused */
2446
a1c95e6b
JB
2447 int unpacked_idx; /* Index into the unpacked buffer */
2448 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2449
4c4b4cd2 2450 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2451 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2452 unsigned char sign;
a1c95e6b 2453
4c4b4cd2
PH
2454 /* Transmit bytes from least to most significant; delta is the direction
2455 the indices move. */
f93fca70 2456 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2457
5b639dea
JB
2458 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2459 bits from SRC. .*/
2460 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2461 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2462 bit_size, unpacked_len);
2463
14f9c5c9 2464 srcBitsLeft = bit_size;
086ca51f 2465 src_bytes_left = src_len;
f93fca70 2466 unpacked_bytes_left = unpacked_len;
14f9c5c9 2467 sign = 0;
f93fca70
JB
2468
2469 if (is_big_endian)
14f9c5c9 2470 {
086ca51f 2471 src_idx = src_len - 1;
f93fca70
JB
2472 if (is_signed_type
2473 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2474 sign = ~0;
d2e4a39e
AS
2475
2476 unusedLS =
4c4b4cd2
PH
2477 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2478 % HOST_CHAR_BIT;
14f9c5c9 2479
f93fca70
JB
2480 if (is_scalar)
2481 {
2482 accumSize = 0;
2483 unpacked_idx = unpacked_len - 1;
2484 }
2485 else
2486 {
4c4b4cd2
PH
2487 /* Non-scalar values must be aligned at a byte boundary... */
2488 accumSize =
2489 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2490 /* ... And are placed at the beginning (most-significant) bytes
2491 of the target. */
086ca51f
JB
2492 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2493 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2494 }
14f9c5c9 2495 }
d2e4a39e 2496 else
14f9c5c9
AS
2497 {
2498 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2499
086ca51f 2500 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2501 unusedLS = bit_offset;
2502 accumSize = 0;
2503
f93fca70 2504 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2505 sign = ~0;
14f9c5c9 2506 }
d2e4a39e 2507
14f9c5c9 2508 accum = 0;
086ca51f 2509 while (src_bytes_left > 0)
14f9c5c9
AS
2510 {
2511 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2512 part of the value. */
d2e4a39e 2513 unsigned int unusedMSMask =
4c4b4cd2
PH
2514 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2515 1;
2516 /* Sign-extend bits for this byte. */
14f9c5c9 2517 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2518
d2e4a39e 2519 accum |=
086ca51f 2520 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2521 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2522 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2523 {
db297a65 2524 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2525 accumSize -= HOST_CHAR_BIT;
2526 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2527 unpacked_bytes_left -= 1;
2528 unpacked_idx += delta;
4c4b4cd2 2529 }
14f9c5c9
AS
2530 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2531 unusedLS = 0;
086ca51f
JB
2532 src_bytes_left -= 1;
2533 src_idx += delta;
14f9c5c9 2534 }
086ca51f 2535 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2536 {
2537 accum |= sign << accumSize;
db297a65 2538 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2539 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2540 if (accumSize < 0)
2541 accumSize = 0;
14f9c5c9 2542 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2543 unpacked_bytes_left -= 1;
2544 unpacked_idx += delta;
14f9c5c9 2545 }
f93fca70
JB
2546}
2547
2548/* Create a new value of type TYPE from the contents of OBJ starting
2549 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2550 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2551 assigning through the result will set the field fetched from.
2552 VALADDR is ignored unless OBJ is NULL, in which case,
2553 VALADDR+OFFSET must address the start of storage containing the
2554 packed value. The value returned in this case is never an lval.
2555 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2556
2557struct value *
2558ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2559 long offset, int bit_offset, int bit_size,
2560 struct type *type)
2561{
2562 struct value *v;
bfb1c796 2563 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2564 gdb_byte *unpacked;
220475ed 2565 const int is_scalar = is_scalar_type (type);
d0a9e810 2566 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2567 gdb::byte_vector staging;
f93fca70
JB
2568
2569 type = ada_check_typedef (type);
2570
d0a9e810 2571 if (obj == NULL)
bfb1c796 2572 src = valaddr + offset;
d0a9e810 2573 else
bfb1c796 2574 src = value_contents (obj) + offset;
d0a9e810
JB
2575
2576 if (is_dynamic_type (type))
2577 {
2578 /* The length of TYPE might by dynamic, so we need to resolve
2579 TYPE in order to know its actual size, which we then use
2580 to create the contents buffer of the value we return.
2581 The difficulty is that the data containing our object is
2582 packed, and therefore maybe not at a byte boundary. So, what
2583 we do, is unpack the data into a byte-aligned buffer, and then
2584 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2585 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2586 staging.resize (staging_len);
d0a9e810
JB
2587
2588 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2589 staging.data (), staging.size (),
d0a9e810
JB
2590 is_big_endian, has_negatives (type),
2591 is_scalar);
d5722aa2 2592 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2593 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2594 {
2595 /* This happens when the length of the object is dynamic,
2596 and is actually smaller than the space reserved for it.
2597 For instance, in an array of variant records, the bit_size
2598 we're given is the array stride, which is constant and
2599 normally equal to the maximum size of its element.
2600 But, in reality, each element only actually spans a portion
2601 of that stride. */
2602 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2603 }
d0a9e810
JB
2604 }
2605
f93fca70
JB
2606 if (obj == NULL)
2607 {
2608 v = allocate_value (type);
bfb1c796 2609 src = valaddr + offset;
f93fca70
JB
2610 }
2611 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2612 {
0cafa88c 2613 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2614 gdb_byte *buf;
0cafa88c 2615
f93fca70 2616 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2617 buf = (gdb_byte *) alloca (src_len);
2618 read_memory (value_address (v), buf, src_len);
2619 src = buf;
f93fca70
JB
2620 }
2621 else
2622 {
2623 v = allocate_value (type);
bfb1c796 2624 src = value_contents (obj) + offset;
f93fca70
JB
2625 }
2626
2627 if (obj != NULL)
2628 {
2629 long new_offset = offset;
2630
2631 set_value_component_location (v, obj);
2632 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2633 set_value_bitsize (v, bit_size);
2634 if (value_bitpos (v) >= HOST_CHAR_BIT)
2635 {
2636 ++new_offset;
2637 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2638 }
2639 set_value_offset (v, new_offset);
2640
2641 /* Also set the parent value. This is needed when trying to
2642 assign a new value (in inferior memory). */
2643 set_value_parent (v, obj);
2644 }
2645 else
2646 set_value_bitsize (v, bit_size);
bfb1c796 2647 unpacked = value_contents_writeable (v);
f93fca70
JB
2648
2649 if (bit_size == 0)
2650 {
2651 memset (unpacked, 0, TYPE_LENGTH (type));
2652 return v;
2653 }
2654
d5722aa2 2655 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2656 {
d0a9e810
JB
2657 /* Small short-cut: If we've unpacked the data into a buffer
2658 of the same size as TYPE's length, then we can reuse that,
2659 instead of doing the unpacking again. */
d5722aa2 2660 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2661 }
d0a9e810
JB
2662 else
2663 ada_unpack_from_contents (src, bit_offset, bit_size,
2664 unpacked, TYPE_LENGTH (type),
2665 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2666
14f9c5c9
AS
2667 return v;
2668}
d2e4a39e 2669
14f9c5c9
AS
2670/* Store the contents of FROMVAL into the location of TOVAL.
2671 Return a new value with the location of TOVAL and contents of
2672 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2673 floating-point or non-scalar types. */
14f9c5c9 2674
d2e4a39e
AS
2675static struct value *
2676ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2677{
df407dfe
AC
2678 struct type *type = value_type (toval);
2679 int bits = value_bitsize (toval);
14f9c5c9 2680
52ce6436
PH
2681 toval = ada_coerce_ref (toval);
2682 fromval = ada_coerce_ref (fromval);
2683
2684 if (ada_is_direct_array_type (value_type (toval)))
2685 toval = ada_coerce_to_simple_array (toval);
2686 if (ada_is_direct_array_type (value_type (fromval)))
2687 fromval = ada_coerce_to_simple_array (fromval);
2688
88e3b34b 2689 if (!deprecated_value_modifiable (toval))
323e0a4a 2690 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2691
d2e4a39e 2692 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2693 && bits > 0
d2e4a39e 2694 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2695 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2696 {
df407dfe
AC
2697 int len = (value_bitpos (toval)
2698 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2699 int from_size;
224c3ddb 2700 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2701 struct value *val;
42ae5230 2702 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2703
2704 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2705 fromval = value_cast (type, fromval);
14f9c5c9 2706
52ce6436 2707 read_memory (to_addr, buffer, len);
aced2898
PH
2708 from_size = value_bitsize (fromval);
2709 if (from_size == 0)
2710 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2711 if (gdbarch_bits_big_endian (get_type_arch (type)))
a99bc3d2
JB
2712 copy_bitwise (buffer, value_bitpos (toval),
2713 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2714 else
a99bc3d2
JB
2715 copy_bitwise (buffer, value_bitpos (toval),
2716 value_contents (fromval), 0, bits, 0);
972daa01 2717 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2718
14f9c5c9 2719 val = value_copy (toval);
0fd88904 2720 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2721 TYPE_LENGTH (type));
04624583 2722 deprecated_set_value_type (val, type);
d2e4a39e 2723
14f9c5c9
AS
2724 return val;
2725 }
2726
2727 return value_assign (toval, fromval);
2728}
2729
2730
7c512744
JB
2731/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2732 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2733 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2734 COMPONENT, and not the inferior's memory. The current contents
2735 of COMPONENT are ignored.
2736
2737 Although not part of the initial design, this function also works
2738 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2739 had a null address, and COMPONENT had an address which is equal to
2740 its offset inside CONTAINER. */
2741
52ce6436
PH
2742static void
2743value_assign_to_component (struct value *container, struct value *component,
2744 struct value *val)
2745{
2746 LONGEST offset_in_container =
42ae5230 2747 (LONGEST) (value_address (component) - value_address (container));
7c512744 2748 int bit_offset_in_container =
52ce6436
PH
2749 value_bitpos (component) - value_bitpos (container);
2750 int bits;
7c512744 2751
52ce6436
PH
2752 val = value_cast (value_type (component), val);
2753
2754 if (value_bitsize (component) == 0)
2755 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2756 else
2757 bits = value_bitsize (component);
2758
50810684 2759 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2a62dfa9
JB
2760 {
2761 int src_offset;
2762
2763 if (is_scalar_type (check_typedef (value_type (component))))
2764 src_offset
2765 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2766 else
2767 src_offset = 0;
a99bc3d2
JB
2768 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2769 value_bitpos (container) + bit_offset_in_container,
2770 value_contents (val), src_offset, bits, 1);
2a62dfa9 2771 }
52ce6436 2772 else
a99bc3d2
JB
2773 copy_bitwise (value_contents_writeable (container) + offset_in_container,
2774 value_bitpos (container) + bit_offset_in_container,
2775 value_contents (val), 0, bits, 0);
7c512744
JB
2776}
2777
736ade86
XR
2778/* Determine if TYPE is an access to an unconstrained array. */
2779
d91e9ea8 2780bool
736ade86
XR
2781ada_is_access_to_unconstrained_array (struct type *type)
2782{
2783 return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
2784 && is_thick_pntr (ada_typedef_target_type (type)));
2785}
2786
4c4b4cd2
PH
2787/* The value of the element of array ARR at the ARITY indices given in IND.
2788 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2789 thereto. */
2790
d2e4a39e
AS
2791struct value *
2792ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2793{
2794 int k;
d2e4a39e
AS
2795 struct value *elt;
2796 struct type *elt_type;
14f9c5c9
AS
2797
2798 elt = ada_coerce_to_simple_array (arr);
2799
df407dfe 2800 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2801 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2802 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2803 return value_subscript_packed (elt, arity, ind);
2804
2805 for (k = 0; k < arity; k += 1)
2806 {
b9c50e9a
XR
2807 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type);
2808
14f9c5c9 2809 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2810 error (_("too many subscripts (%d expected)"), k);
b9c50e9a 2811
2497b498 2812 elt = value_subscript (elt, pos_atr (ind[k]));
b9c50e9a
XR
2813
2814 if (ada_is_access_to_unconstrained_array (saved_elt_type)
2815 && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF)
2816 {
2817 /* The element is a typedef to an unconstrained array,
2818 except that the value_subscript call stripped the
2819 typedef layer. The typedef layer is GNAT's way to
2820 specify that the element is, at the source level, an
2821 access to the unconstrained array, rather than the
2822 unconstrained array. So, we need to restore that
2823 typedef layer, which we can do by forcing the element's
2824 type back to its original type. Otherwise, the returned
2825 value is going to be printed as the array, rather
2826 than as an access. Another symptom of the same issue
2827 would be that an expression trying to dereference the
2828 element would also be improperly rejected. */
2829 deprecated_set_value_type (elt, saved_elt_type);
2830 }
2831
2832 elt_type = ada_check_typedef (value_type (elt));
14f9c5c9 2833 }
b9c50e9a 2834
14f9c5c9
AS
2835 return elt;
2836}
2837
deede10c
JB
2838/* Assuming ARR is a pointer to a GDB array, the value of the element
2839 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2840 Does not read the entire array into memory.
2841
2842 Note: Unlike what one would expect, this function is used instead of
2843 ada_value_subscript for basically all non-packed array types. The reason
2844 for this is that a side effect of doing our own pointer arithmetics instead
2845 of relying on value_subscript is that there is no implicit typedef peeling.
2846 This is important for arrays of array accesses, where it allows us to
2847 preserve the fact that the array's element is an array access, where the
2848 access part os encoded in a typedef layer. */
14f9c5c9 2849
2c0b251b 2850static struct value *
deede10c 2851ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2852{
2853 int k;
919e6dbe 2854 struct value *array_ind = ada_value_ind (arr);
deede10c 2855 struct type *type
919e6dbe
PMR
2856 = check_typedef (value_enclosing_type (array_ind));
2857
2858 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2859 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2860 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2861
2862 for (k = 0; k < arity; k += 1)
2863 {
2864 LONGEST lwb, upb;
aa715135 2865 struct value *lwb_value;
14f9c5c9
AS
2866
2867 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2868 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2869 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2870 value_copy (arr));
14f9c5c9 2871 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2872 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2873 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2874 type = TYPE_TARGET_TYPE (type);
2875 }
2876
2877 return value_ind (arr);
2878}
2879
0b5d8877 2880/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2881 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2882 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2883 this array is LOW, as per Ada rules. */
0b5d8877 2884static struct value *
f5938064
JG
2885ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2886 int low, int high)
0b5d8877 2887{
b0dd7688 2888 struct type *type0 = ada_check_typedef (type);
aa715135 2889 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2890 struct type *index_type
aa715135 2891 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2892 struct type *slice_type = create_array_type_with_stride
2893 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2894 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2895 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2896 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2897 LONGEST base_low_pos, low_pos;
2898 CORE_ADDR base;
2899
2900 if (!discrete_position (base_index_type, low, &low_pos)
2901 || !discrete_position (base_index_type, base_low, &base_low_pos))
2902 {
2903 warning (_("unable to get positions in slice, use bounds instead"));
2904 low_pos = low;
2905 base_low_pos = base_low;
2906 }
5b4ee69b 2907
aa715135
JG
2908 base = value_as_address (array_ptr)
2909 + ((low_pos - base_low_pos)
2910 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2911 return value_at_lazy (slice_type, base);
0b5d8877
PH
2912}
2913
2914
2915static struct value *
2916ada_value_slice (struct value *array, int low, int high)
2917{
b0dd7688 2918 struct type *type = ada_check_typedef (value_type (array));
aa715135 2919 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2920 struct type *index_type
2921 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2922 struct type *slice_type = create_array_type_with_stride
2923 (NULL, TYPE_TARGET_TYPE (type), index_type,
2924 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2925 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2926 LONGEST low_pos, high_pos;
5b4ee69b 2927
aa715135
JG
2928 if (!discrete_position (base_index_type, low, &low_pos)
2929 || !discrete_position (base_index_type, high, &high_pos))
2930 {
2931 warning (_("unable to get positions in slice, use bounds instead"));
2932 low_pos = low;
2933 high_pos = high;
2934 }
2935
2936 return value_cast (slice_type,
2937 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2938}
2939
14f9c5c9
AS
2940/* If type is a record type in the form of a standard GNAT array
2941 descriptor, returns the number of dimensions for type. If arr is a
2942 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2943 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2944
2945int
d2e4a39e 2946ada_array_arity (struct type *type)
14f9c5c9
AS
2947{
2948 int arity;
2949
2950 if (type == NULL)
2951 return 0;
2952
2953 type = desc_base_type (type);
2954
2955 arity = 0;
d2e4a39e 2956 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2957 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2958 else
2959 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2960 {
4c4b4cd2 2961 arity += 1;
61ee279c 2962 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2963 }
d2e4a39e 2964
14f9c5c9
AS
2965 return arity;
2966}
2967
2968/* If TYPE is a record type in the form of a standard GNAT array
2969 descriptor or a simple array type, returns the element type for
2970 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2971 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2972
d2e4a39e
AS
2973struct type *
2974ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2975{
2976 type = desc_base_type (type);
2977
d2e4a39e 2978 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2979 {
2980 int k;
d2e4a39e 2981 struct type *p_array_type;
14f9c5c9 2982
556bdfd4 2983 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2984
2985 k = ada_array_arity (type);
2986 if (k == 0)
4c4b4cd2 2987 return NULL;
d2e4a39e 2988
4c4b4cd2 2989 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2990 if (nindices >= 0 && k > nindices)
4c4b4cd2 2991 k = nindices;
d2e4a39e 2992 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2993 {
61ee279c 2994 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2995 k -= 1;
2996 }
14f9c5c9
AS
2997 return p_array_type;
2998 }
2999 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3000 {
3001 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3002 {
3003 type = TYPE_TARGET_TYPE (type);
3004 nindices -= 1;
3005 }
14f9c5c9
AS
3006 return type;
3007 }
3008
3009 return NULL;
3010}
3011
4c4b4cd2 3012/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3013 Does not examine memory. Throws an error if N is invalid or TYPE
3014 is not an array type. NAME is the name of the Ada attribute being
3015 evaluated ('range, 'first, 'last, or 'length); it is used in building
3016 the error message. */
14f9c5c9 3017
1eea4ebd
UW
3018static struct type *
3019ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3020{
4c4b4cd2
PH
3021 struct type *result_type;
3022
14f9c5c9
AS
3023 type = desc_base_type (type);
3024
1eea4ebd
UW
3025 if (n < 0 || n > ada_array_arity (type))
3026 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3027
4c4b4cd2 3028 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3029 {
3030 int i;
3031
3032 for (i = 1; i < n; i += 1)
4c4b4cd2 3033 type = TYPE_TARGET_TYPE (type);
262452ec 3034 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3035 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3036 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3037 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3038 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3039 result_type = NULL;
14f9c5c9 3040 }
d2e4a39e 3041 else
1eea4ebd
UW
3042 {
3043 result_type = desc_index_type (desc_bounds_type (type), n);
3044 if (result_type == NULL)
3045 error (_("attempt to take bound of something that is not an array"));
3046 }
3047
3048 return result_type;
14f9c5c9
AS
3049}
3050
3051/* Given that arr is an array type, returns the lower bound of the
3052 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3053 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3054 array-descriptor type. It works for other arrays with bounds supplied
3055 by run-time quantities other than discriminants. */
14f9c5c9 3056
abb68b3e 3057static LONGEST
fb5e3d5c 3058ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3059{
8a48ac95 3060 struct type *type, *index_type_desc, *index_type;
1ce677a4 3061 int i;
262452ec
JK
3062
3063 gdb_assert (which == 0 || which == 1);
14f9c5c9 3064
ad82864c
JB
3065 if (ada_is_constrained_packed_array_type (arr_type))
3066 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3067
4c4b4cd2 3068 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3069 return (LONGEST) - which;
14f9c5c9
AS
3070
3071 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3072 type = TYPE_TARGET_TYPE (arr_type);
3073 else
3074 type = arr_type;
3075
bafffb51
JB
3076 if (TYPE_FIXED_INSTANCE (type))
3077 {
3078 /* The array has already been fixed, so we do not need to
3079 check the parallel ___XA type again. That encoding has
3080 already been applied, so ignore it now. */
3081 index_type_desc = NULL;
3082 }
3083 else
3084 {
3085 index_type_desc = ada_find_parallel_type (type, "___XA");
3086 ada_fixup_array_indexes_type (index_type_desc);
3087 }
3088
262452ec 3089 if (index_type_desc != NULL)
28c85d6c
JB
3090 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3091 NULL);
262452ec 3092 else
8a48ac95
JB
3093 {
3094 struct type *elt_type = check_typedef (type);
3095
3096 for (i = 1; i < n; i++)
3097 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3098
3099 index_type = TYPE_INDEX_TYPE (elt_type);
3100 }
262452ec 3101
43bbcdc2
PH
3102 return
3103 (LONGEST) (which == 0
3104 ? ada_discrete_type_low_bound (index_type)
3105 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3106}
3107
3108/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3109 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3110 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3111 supplied by run-time quantities other than discriminants. */
14f9c5c9 3112
1eea4ebd 3113static LONGEST
4dc81987 3114ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3115{
eb479039
JB
3116 struct type *arr_type;
3117
3118 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3119 arr = value_ind (arr);
3120 arr_type = value_enclosing_type (arr);
14f9c5c9 3121
ad82864c
JB
3122 if (ada_is_constrained_packed_array_type (arr_type))
3123 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3124 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3125 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3126 else
1eea4ebd 3127 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3128}
3129
3130/* Given that arr is an array value, returns the length of the
3131 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3132 supplied by run-time quantities other than discriminants.
3133 Does not work for arrays indexed by enumeration types with representation
3134 clauses at the moment. */
14f9c5c9 3135
1eea4ebd 3136static LONGEST
d2e4a39e 3137ada_array_length (struct value *arr, int n)
14f9c5c9 3138{
aa715135
JG
3139 struct type *arr_type, *index_type;
3140 int low, high;
eb479039
JB
3141
3142 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3143 arr = value_ind (arr);
3144 arr_type = value_enclosing_type (arr);
14f9c5c9 3145
ad82864c
JB
3146 if (ada_is_constrained_packed_array_type (arr_type))
3147 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3148
4c4b4cd2 3149 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3150 {
3151 low = ada_array_bound_from_type (arr_type, n, 0);
3152 high = ada_array_bound_from_type (arr_type, n, 1);
3153 }
14f9c5c9 3154 else
aa715135
JG
3155 {
3156 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3157 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3158 }
3159
f168693b 3160 arr_type = check_typedef (arr_type);
7150d33c 3161 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3162 if (index_type != NULL)
3163 {
3164 struct type *base_type;
3165 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3166 base_type = TYPE_TARGET_TYPE (index_type);
3167 else
3168 base_type = index_type;
3169
3170 low = pos_atr (value_from_longest (base_type, low));
3171 high = pos_atr (value_from_longest (base_type, high));
3172 }
3173 return high - low + 1;
4c4b4cd2
PH
3174}
3175
3176/* An empty array whose type is that of ARR_TYPE (an array type),
3177 with bounds LOW to LOW-1. */
3178
3179static struct value *
3180empty_array (struct type *arr_type, int low)
3181{
b0dd7688 3182 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3183 struct type *index_type
3184 = create_static_range_type
3185 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3186 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3187
0b5d8877 3188 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3189}
14f9c5c9 3190\f
d2e4a39e 3191
4c4b4cd2 3192 /* Name resolution */
14f9c5c9 3193
4c4b4cd2
PH
3194/* The "decoded" name for the user-definable Ada operator corresponding
3195 to OP. */
14f9c5c9 3196
d2e4a39e 3197static const char *
4c4b4cd2 3198ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3199{
3200 int i;
3201
4c4b4cd2 3202 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3203 {
3204 if (ada_opname_table[i].op == op)
4c4b4cd2 3205 return ada_opname_table[i].decoded;
14f9c5c9 3206 }
323e0a4a 3207 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3208}
3209
3210
4c4b4cd2
PH
3211/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3212 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3213 undefined namespace) and converts operators that are
3214 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3215 non-null, it provides a preferred result type [at the moment, only
3216 type void has any effect---causing procedures to be preferred over
3217 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3218 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3219
4c4b4cd2 3220static void
e9d9f57e 3221resolve (expression_up *expp, int void_context_p)
14f9c5c9 3222{
30b15541
UW
3223 struct type *context_type = NULL;
3224 int pc = 0;
3225
3226 if (void_context_p)
3227 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3228
3229 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3230}
3231
4c4b4cd2
PH
3232/* Resolve the operator of the subexpression beginning at
3233 position *POS of *EXPP. "Resolving" consists of replacing
3234 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3235 with their resolutions, replacing built-in operators with
3236 function calls to user-defined operators, where appropriate, and,
3237 when DEPROCEDURE_P is non-zero, converting function-valued variables
3238 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3239 are as in ada_resolve, above. */
14f9c5c9 3240
d2e4a39e 3241static struct value *
e9d9f57e 3242resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
76a01679 3243 struct type *context_type)
14f9c5c9
AS
3244{
3245 int pc = *pos;
3246 int i;
4c4b4cd2 3247 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3248 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3249 struct value **argvec; /* Vector of operand types (alloca'ed). */
3250 int nargs; /* Number of operands. */
52ce6436 3251 int oplen;
14f9c5c9
AS
3252
3253 argvec = NULL;
3254 nargs = 0;
e9d9f57e 3255 exp = expp->get ();
14f9c5c9 3256
52ce6436
PH
3257 /* Pass one: resolve operands, saving their types and updating *pos,
3258 if needed. */
14f9c5c9
AS
3259 switch (op)
3260 {
4c4b4cd2
PH
3261 case OP_FUNCALL:
3262 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3263 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3264 *pos += 7;
4c4b4cd2
PH
3265 else
3266 {
3267 *pos += 3;
3268 resolve_subexp (expp, pos, 0, NULL);
3269 }
3270 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3271 break;
3272
14f9c5c9 3273 case UNOP_ADDR:
4c4b4cd2
PH
3274 *pos += 1;
3275 resolve_subexp (expp, pos, 0, NULL);
3276 break;
3277
52ce6436
PH
3278 case UNOP_QUAL:
3279 *pos += 3;
17466c1a 3280 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3281 break;
3282
52ce6436 3283 case OP_ATR_MODULUS:
4c4b4cd2
PH
3284 case OP_ATR_SIZE:
3285 case OP_ATR_TAG:
4c4b4cd2
PH
3286 case OP_ATR_FIRST:
3287 case OP_ATR_LAST:
3288 case OP_ATR_LENGTH:
3289 case OP_ATR_POS:
3290 case OP_ATR_VAL:
4c4b4cd2
PH
3291 case OP_ATR_MIN:
3292 case OP_ATR_MAX:
52ce6436
PH
3293 case TERNOP_IN_RANGE:
3294 case BINOP_IN_BOUNDS:
3295 case UNOP_IN_RANGE:
3296 case OP_AGGREGATE:
3297 case OP_OTHERS:
3298 case OP_CHOICES:
3299 case OP_POSITIONAL:
3300 case OP_DISCRETE_RANGE:
3301 case OP_NAME:
3302 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3303 *pos += oplen;
14f9c5c9
AS
3304 break;
3305
3306 case BINOP_ASSIGN:
3307 {
4c4b4cd2
PH
3308 struct value *arg1;
3309
3310 *pos += 1;
3311 arg1 = resolve_subexp (expp, pos, 0, NULL);
3312 if (arg1 == NULL)
3313 resolve_subexp (expp, pos, 1, NULL);
3314 else
df407dfe 3315 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3316 break;
14f9c5c9
AS
3317 }
3318
4c4b4cd2 3319 case UNOP_CAST:
4c4b4cd2
PH
3320 *pos += 3;
3321 nargs = 1;
3322 break;
14f9c5c9 3323
4c4b4cd2
PH
3324 case BINOP_ADD:
3325 case BINOP_SUB:
3326 case BINOP_MUL:
3327 case BINOP_DIV:
3328 case BINOP_REM:
3329 case BINOP_MOD:
3330 case BINOP_EXP:
3331 case BINOP_CONCAT:
3332 case BINOP_LOGICAL_AND:
3333 case BINOP_LOGICAL_OR:
3334 case BINOP_BITWISE_AND:
3335 case BINOP_BITWISE_IOR:
3336 case BINOP_BITWISE_XOR:
14f9c5c9 3337
4c4b4cd2
PH
3338 case BINOP_EQUAL:
3339 case BINOP_NOTEQUAL:
3340 case BINOP_LESS:
3341 case BINOP_GTR:
3342 case BINOP_LEQ:
3343 case BINOP_GEQ:
14f9c5c9 3344
4c4b4cd2
PH
3345 case BINOP_REPEAT:
3346 case BINOP_SUBSCRIPT:
3347 case BINOP_COMMA:
40c8aaa9
JB
3348 *pos += 1;
3349 nargs = 2;
3350 break;
14f9c5c9 3351
4c4b4cd2
PH
3352 case UNOP_NEG:
3353 case UNOP_PLUS:
3354 case UNOP_LOGICAL_NOT:
3355 case UNOP_ABS:
3356 case UNOP_IND:
3357 *pos += 1;
3358 nargs = 1;
3359 break;
14f9c5c9 3360
4c4b4cd2 3361 case OP_LONG:
edd079d9 3362 case OP_FLOAT:
4c4b4cd2 3363 case OP_VAR_VALUE:
74ea4be4 3364 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3365 *pos += 4;
3366 break;
14f9c5c9 3367
4c4b4cd2
PH
3368 case OP_TYPE:
3369 case OP_BOOL:
3370 case OP_LAST:
4c4b4cd2
PH
3371 case OP_INTERNALVAR:
3372 *pos += 3;
3373 break;
14f9c5c9 3374
4c4b4cd2
PH
3375 case UNOP_MEMVAL:
3376 *pos += 3;
3377 nargs = 1;
3378 break;
3379
67f3407f
DJ
3380 case OP_REGISTER:
3381 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3382 break;
3383
4c4b4cd2
PH
3384 case STRUCTOP_STRUCT:
3385 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3386 nargs = 1;
3387 break;
3388
4c4b4cd2 3389 case TERNOP_SLICE:
4c4b4cd2
PH
3390 *pos += 1;
3391 nargs = 3;
3392 break;
3393
52ce6436 3394 case OP_STRING:
14f9c5c9 3395 break;
4c4b4cd2
PH
3396
3397 default:
323e0a4a 3398 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3399 }
3400
8d749320 3401 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2
PH
3402 for (i = 0; i < nargs; i += 1)
3403 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3404 argvec[i] = NULL;
e9d9f57e 3405 exp = expp->get ();
4c4b4cd2
PH
3406
3407 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3408 switch (op)
3409 {
3410 default:
3411 break;
3412
14f9c5c9 3413 case OP_VAR_VALUE:
4c4b4cd2 3414 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3415 {
54d343a2 3416 std::vector<struct block_symbol> candidates;
76a01679
JB
3417 int n_candidates;
3418
3419 n_candidates =
3420 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3421 (exp->elts[pc + 2].symbol),
3422 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3423 &candidates);
76a01679
JB
3424
3425 if (n_candidates > 1)
3426 {
3427 /* Types tend to get re-introduced locally, so if there
3428 are any local symbols that are not types, first filter
3429 out all types. */
3430 int j;
3431 for (j = 0; j < n_candidates; j += 1)
d12307c1 3432 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3433 {
3434 case LOC_REGISTER:
3435 case LOC_ARG:
3436 case LOC_REF_ARG:
76a01679
JB
3437 case LOC_REGPARM_ADDR:
3438 case LOC_LOCAL:
76a01679 3439 case LOC_COMPUTED:
76a01679
JB
3440 goto FoundNonType;
3441 default:
3442 break;
3443 }
3444 FoundNonType:
3445 if (j < n_candidates)
3446 {
3447 j = 0;
3448 while (j < n_candidates)
3449 {
d12307c1 3450 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3451 {
3452 candidates[j] = candidates[n_candidates - 1];
3453 n_candidates -= 1;
3454 }
3455 else
3456 j += 1;
3457 }
3458 }
3459 }
3460
3461 if (n_candidates == 0)
323e0a4a 3462 error (_("No definition found for %s"),
76a01679
JB
3463 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3464 else if (n_candidates == 1)
3465 i = 0;
3466 else if (deprocedure_p
54d343a2 3467 && !is_nonfunction (candidates.data (), n_candidates))
76a01679 3468 {
06d5cf63 3469 i = ada_resolve_function
54d343a2 3470 (candidates.data (), n_candidates, NULL, 0,
06d5cf63
JB
3471 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3472 context_type);
76a01679 3473 if (i < 0)
323e0a4a 3474 error (_("Could not find a match for %s"),
76a01679
JB
3475 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3476 }
3477 else
3478 {
323e0a4a 3479 printf_filtered (_("Multiple matches for %s\n"),
76a01679 3480 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
54d343a2 3481 user_select_syms (candidates.data (), n_candidates, 1);
76a01679
JB
3482 i = 0;
3483 }
3484
3485 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3486 exp->elts[pc + 2].symbol = candidates[i].symbol;
aee1fcdf 3487 innermost_block.update (candidates[i]);
76a01679
JB
3488 }
3489
3490 if (deprocedure_p
3491 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3492 == TYPE_CODE_FUNC))
3493 {
424da6cf 3494 replace_operator_with_call (expp, pc, 0, 4,
76a01679
JB
3495 exp->elts[pc + 2].symbol,
3496 exp->elts[pc + 1].block);
e9d9f57e 3497 exp = expp->get ();
76a01679 3498 }
14f9c5c9
AS
3499 break;
3500
3501 case OP_FUNCALL:
3502 {
4c4b4cd2 3503 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3504 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3505 {
54d343a2 3506 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3507 int n_candidates;
3508
3509 n_candidates =
76a01679
JB
3510 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3511 (exp->elts[pc + 5].symbol),
3512 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3513 &candidates);
ec6a20c2 3514
4c4b4cd2
PH
3515 if (n_candidates == 1)
3516 i = 0;
3517 else
3518 {
06d5cf63 3519 i = ada_resolve_function
54d343a2 3520 (candidates.data (), n_candidates,
06d5cf63
JB
3521 argvec, nargs,
3522 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3523 context_type);
4c4b4cd2 3524 if (i < 0)
323e0a4a 3525 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3526 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3527 }
3528
3529 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3530 exp->elts[pc + 5].symbol = candidates[i].symbol;
aee1fcdf 3531 innermost_block.update (candidates[i]);
4c4b4cd2 3532 }
14f9c5c9
AS
3533 }
3534 break;
3535 case BINOP_ADD:
3536 case BINOP_SUB:
3537 case BINOP_MUL:
3538 case BINOP_DIV:
3539 case BINOP_REM:
3540 case BINOP_MOD:
3541 case BINOP_CONCAT:
3542 case BINOP_BITWISE_AND:
3543 case BINOP_BITWISE_IOR:
3544 case BINOP_BITWISE_XOR:
3545 case BINOP_EQUAL:
3546 case BINOP_NOTEQUAL:
3547 case BINOP_LESS:
3548 case BINOP_GTR:
3549 case BINOP_LEQ:
3550 case BINOP_GEQ:
3551 case BINOP_EXP:
3552 case UNOP_NEG:
3553 case UNOP_PLUS:
3554 case UNOP_LOGICAL_NOT:
3555 case UNOP_ABS:
3556 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3557 {
54d343a2 3558 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3559 int n_candidates;
3560
3561 n_candidates =
b5ec771e 3562 ada_lookup_symbol_list (ada_decoded_op_name (op),
4c4b4cd2 3563 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3564 &candidates);
ec6a20c2 3565
54d343a2
TT
3566 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3567 nargs, ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3568 if (i < 0)
3569 break;
3570
d12307c1
PMR
3571 replace_operator_with_call (expp, pc, nargs, 1,
3572 candidates[i].symbol,
3573 candidates[i].block);
e9d9f57e 3574 exp = expp->get ();
4c4b4cd2 3575 }
14f9c5c9 3576 break;
4c4b4cd2
PH
3577
3578 case OP_TYPE:
b3dbf008 3579 case OP_REGISTER:
4c4b4cd2 3580 return NULL;
14f9c5c9
AS
3581 }
3582
3583 *pos = pc;
ced9779b
JB
3584 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3585 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3586 exp->elts[pc + 1].objfile,
3587 exp->elts[pc + 2].msymbol);
3588 else
3589 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3590}
3591
3592/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3593 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3594 a non-pointer. */
14f9c5c9 3595/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3596 liberal. */
14f9c5c9
AS
3597
3598static int
4dc81987 3599ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3600{
61ee279c
PH
3601 ftype = ada_check_typedef (ftype);
3602 atype = ada_check_typedef (atype);
14f9c5c9
AS
3603
3604 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3605 ftype = TYPE_TARGET_TYPE (ftype);
3606 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3607 atype = TYPE_TARGET_TYPE (atype);
3608
d2e4a39e 3609 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3610 {
3611 default:
5b3d5b7d 3612 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3613 case TYPE_CODE_PTR:
3614 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3615 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3616 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3617 else
1265e4aa
JB
3618 return (may_deref
3619 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3620 case TYPE_CODE_INT:
3621 case TYPE_CODE_ENUM:
3622 case TYPE_CODE_RANGE:
3623 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3624 {
3625 case TYPE_CODE_INT:
3626 case TYPE_CODE_ENUM:
3627 case TYPE_CODE_RANGE:
3628 return 1;
3629 default:
3630 return 0;
3631 }
14f9c5c9
AS
3632
3633 case TYPE_CODE_ARRAY:
d2e4a39e 3634 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3635 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3636
3637 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3638 if (ada_is_array_descriptor_type (ftype))
3639 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3640 || ada_is_array_descriptor_type (atype));
14f9c5c9 3641 else
4c4b4cd2
PH
3642 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3643 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3644
3645 case TYPE_CODE_UNION:
3646 case TYPE_CODE_FLT:
3647 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3648 }
3649}
3650
3651/* Return non-zero if the formals of FUNC "sufficiently match" the
3652 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3653 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3654 argument function. */
14f9c5c9
AS
3655
3656static int
d2e4a39e 3657ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3658{
3659 int i;
d2e4a39e 3660 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3661
1265e4aa
JB
3662 if (SYMBOL_CLASS (func) == LOC_CONST
3663 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3664 return (n_actuals == 0);
3665 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3666 return 0;
3667
3668 if (TYPE_NFIELDS (func_type) != n_actuals)
3669 return 0;
3670
3671 for (i = 0; i < n_actuals; i += 1)
3672 {
4c4b4cd2 3673 if (actuals[i] == NULL)
76a01679
JB
3674 return 0;
3675 else
3676 {
5b4ee69b
MS
3677 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3678 i));
df407dfe 3679 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3680
76a01679
JB
3681 if (!ada_type_match (ftype, atype, 1))
3682 return 0;
3683 }
14f9c5c9
AS
3684 }
3685 return 1;
3686}
3687
3688/* False iff function type FUNC_TYPE definitely does not produce a value
3689 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3690 FUNC_TYPE is not a valid function type with a non-null return type
3691 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3692
3693static int
d2e4a39e 3694return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3695{
d2e4a39e 3696 struct type *return_type;
14f9c5c9
AS
3697
3698 if (func_type == NULL)
3699 return 1;
3700
4c4b4cd2 3701 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3702 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3703 else
18af8284 3704 return_type = get_base_type (func_type);
14f9c5c9
AS
3705 if (return_type == NULL)
3706 return 1;
3707
18af8284 3708 context_type = get_base_type (context_type);
14f9c5c9
AS
3709
3710 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3711 return context_type == NULL || return_type == context_type;
3712 else if (context_type == NULL)
3713 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3714 else
3715 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3716}
3717
3718
4c4b4cd2 3719/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3720 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3721 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3722 that returns that type, then eliminate matches that don't. If
3723 CONTEXT_TYPE is void and there is at least one match that does not
3724 return void, eliminate all matches that do.
3725
14f9c5c9
AS
3726 Asks the user if there is more than one match remaining. Returns -1
3727 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3728 solely for messages. May re-arrange and modify SYMS in
3729 the process; the index returned is for the modified vector. */
14f9c5c9 3730
4c4b4cd2 3731static int
d12307c1 3732ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3733 int nsyms, struct value **args, int nargs,
3734 const char *name, struct type *context_type)
14f9c5c9 3735{
30b15541 3736 int fallback;
14f9c5c9 3737 int k;
4c4b4cd2 3738 int m; /* Number of hits */
14f9c5c9 3739
d2e4a39e 3740 m = 0;
30b15541
UW
3741 /* In the first pass of the loop, we only accept functions matching
3742 context_type. If none are found, we add a second pass of the loop
3743 where every function is accepted. */
3744 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3745 {
3746 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3747 {
d12307c1 3748 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3749
d12307c1 3750 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3751 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3752 {
3753 syms[m] = syms[k];
3754 m += 1;
3755 }
3756 }
14f9c5c9
AS
3757 }
3758
dc5c8746
PMR
3759 /* If we got multiple matches, ask the user which one to use. Don't do this
3760 interactive thing during completion, though, as the purpose of the
3761 completion is providing a list of all possible matches. Prompting the
3762 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3763 if (m == 0)
3764 return -1;
dc5c8746 3765 else if (m > 1 && !parse_completion)
14f9c5c9 3766 {
323e0a4a 3767 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3768 user_select_syms (syms, m, 1);
14f9c5c9
AS
3769 return 0;
3770 }
3771 return 0;
3772}
3773
4c4b4cd2
PH
3774/* Returns true (non-zero) iff decoded name N0 should appear before N1
3775 in a listing of choices during disambiguation (see sort_choices, below).
3776 The idea is that overloadings of a subprogram name from the
3777 same package should sort in their source order. We settle for ordering
3778 such symbols by their trailing number (__N or $N). */
3779
14f9c5c9 3780static int
0d5cff50 3781encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3782{
3783 if (N1 == NULL)
3784 return 0;
3785 else if (N0 == NULL)
3786 return 1;
3787 else
3788 {
3789 int k0, k1;
5b4ee69b 3790
d2e4a39e 3791 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3792 ;
d2e4a39e 3793 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3794 ;
d2e4a39e 3795 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3796 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3797 {
3798 int n0, n1;
5b4ee69b 3799
4c4b4cd2
PH
3800 n0 = k0;
3801 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3802 n0 -= 1;
3803 n1 = k1;
3804 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3805 n1 -= 1;
3806 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3807 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3808 }
14f9c5c9
AS
3809 return (strcmp (N0, N1) < 0);
3810 }
3811}
d2e4a39e 3812
4c4b4cd2
PH
3813/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3814 encoded names. */
3815
d2e4a39e 3816static void
d12307c1 3817sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3818{
4c4b4cd2 3819 int i;
5b4ee69b 3820
d2e4a39e 3821 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3822 {
d12307c1 3823 struct block_symbol sym = syms[i];
14f9c5c9
AS
3824 int j;
3825
d2e4a39e 3826 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3827 {
d12307c1
PMR
3828 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3829 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3830 break;
3831 syms[j + 1] = syms[j];
3832 }
d2e4a39e 3833 syms[j + 1] = sym;
14f9c5c9
AS
3834 }
3835}
3836
d72413e6
PMR
3837/* Whether GDB should display formals and return types for functions in the
3838 overloads selection menu. */
3839static int print_signatures = 1;
3840
3841/* Print the signature for SYM on STREAM according to the FLAGS options. For
3842 all but functions, the signature is just the name of the symbol. For
3843 functions, this is the name of the function, the list of types for formals
3844 and the return type (if any). */
3845
3846static void
3847ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3848 const struct type_print_options *flags)
3849{
3850 struct type *type = SYMBOL_TYPE (sym);
3851
3852 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3853 if (!print_signatures
3854 || type == NULL
3855 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3856 return;
3857
3858 if (TYPE_NFIELDS (type) > 0)
3859 {
3860 int i;
3861
3862 fprintf_filtered (stream, " (");
3863 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3864 {
3865 if (i > 0)
3866 fprintf_filtered (stream, "; ");
3867 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3868 flags);
3869 }
3870 fprintf_filtered (stream, ")");
3871 }
3872 if (TYPE_TARGET_TYPE (type) != NULL
3873 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3874 {
3875 fprintf_filtered (stream, " return ");
3876 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3877 }
3878}
3879
4c4b4cd2
PH
3880/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3881 by asking the user (if necessary), returning the number selected,
3882 and setting the first elements of SYMS items. Error if no symbols
3883 selected. */
14f9c5c9
AS
3884
3885/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3886 to be re-integrated one of these days. */
14f9c5c9
AS
3887
3888int
d12307c1 3889user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3890{
3891 int i;
8d749320 3892 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3893 int n_chosen;
3894 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3895 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3896
3897 if (max_results < 1)
323e0a4a 3898 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3899 if (nsyms <= 1)
3900 return nsyms;
3901
717d2f5a
JB
3902 if (select_mode == multiple_symbols_cancel)
3903 error (_("\
3904canceled because the command is ambiguous\n\
3905See set/show multiple-symbol."));
3906
3907 /* If select_mode is "all", then return all possible symbols.
3908 Only do that if more than one symbol can be selected, of course.
3909 Otherwise, display the menu as usual. */
3910 if (select_mode == multiple_symbols_all && max_results > 1)
3911 return nsyms;
3912
323e0a4a 3913 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3914 if (max_results > 1)
323e0a4a 3915 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3916
4c4b4cd2 3917 sort_choices (syms, nsyms);
14f9c5c9
AS
3918
3919 for (i = 0; i < nsyms; i += 1)
3920 {
d12307c1 3921 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3922 continue;
3923
d12307c1 3924 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3925 {
76a01679 3926 struct symtab_and_line sal =
d12307c1 3927 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3928
d72413e6
PMR
3929 printf_unfiltered ("[%d] ", i + first_choice);
3930 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3931 &type_print_raw_options);
323e0a4a 3932 if (sal.symtab == NULL)
d72413e6 3933 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3934 sal.line);
3935 else
d72413e6 3936 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3937 symtab_to_filename_for_display (sal.symtab),
3938 sal.line);
4c4b4cd2
PH
3939 continue;
3940 }
d2e4a39e 3941 else
4c4b4cd2
PH
3942 {
3943 int is_enumeral =
d12307c1
PMR
3944 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3945 && SYMBOL_TYPE (syms[i].symbol) != NULL
3946 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3947 struct symtab *symtab = NULL;
3948
d12307c1
PMR
3949 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3950 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3951
d12307c1 3952 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3953 {
3954 printf_unfiltered ("[%d] ", i + first_choice);
3955 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3956 &type_print_raw_options);
3957 printf_unfiltered (_(" at %s:%d\n"),
3958 symtab_to_filename_for_display (symtab),
3959 SYMBOL_LINE (syms[i].symbol));
3960 }
76a01679 3961 else if (is_enumeral
d12307c1 3962 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3963 {
a3f17187 3964 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3965 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3966 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3967 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3968 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3969 }
d72413e6
PMR
3970 else
3971 {
3972 printf_unfiltered ("[%d] ", i + first_choice);
3973 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3974 &type_print_raw_options);
3975
3976 if (symtab != NULL)
3977 printf_unfiltered (is_enumeral
3978 ? _(" in %s (enumeral)\n")
3979 : _(" at %s:?\n"),
3980 symtab_to_filename_for_display (symtab));
3981 else
3982 printf_unfiltered (is_enumeral
3983 ? _(" (enumeral)\n")
3984 : _(" at ?\n"));
3985 }
4c4b4cd2 3986 }
14f9c5c9 3987 }
d2e4a39e 3988
14f9c5c9 3989 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3990 "overload-choice");
14f9c5c9
AS
3991
3992 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3993 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3994
3995 return n_chosen;
3996}
3997
3998/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3999 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4000 order in CHOICES[0 .. N-1], and return N.
4001
4002 The user types choices as a sequence of numbers on one line
4003 separated by blanks, encoding them as follows:
4004
4c4b4cd2 4005 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4006 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4007 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4008
4c4b4cd2 4009 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4010
4011 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4012 prompts (for use with the -f switch). */
14f9c5c9
AS
4013
4014int
d2e4a39e 4015get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4016 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4017{
d2e4a39e 4018 char *args;
a121b7c1 4019 const char *prompt;
14f9c5c9
AS
4020 int n_chosen;
4021 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4022
14f9c5c9
AS
4023 prompt = getenv ("PS2");
4024 if (prompt == NULL)
0bcd0149 4025 prompt = "> ";
14f9c5c9 4026
89fbedf3 4027 args = command_line_input (prompt, annotation_suffix);
d2e4a39e 4028
14f9c5c9 4029 if (args == NULL)
323e0a4a 4030 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4031
4032 n_chosen = 0;
76a01679 4033
4c4b4cd2
PH
4034 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4035 order, as given in args. Choices are validated. */
14f9c5c9
AS
4036 while (1)
4037 {
d2e4a39e 4038 char *args2;
14f9c5c9
AS
4039 int choice, j;
4040
0fcd72ba 4041 args = skip_spaces (args);
14f9c5c9 4042 if (*args == '\0' && n_chosen == 0)
323e0a4a 4043 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4044 else if (*args == '\0')
4c4b4cd2 4045 break;
14f9c5c9
AS
4046
4047 choice = strtol (args, &args2, 10);
d2e4a39e 4048 if (args == args2 || choice < 0
4c4b4cd2 4049 || choice > n_choices + first_choice - 1)
323e0a4a 4050 error (_("Argument must be choice number"));
14f9c5c9
AS
4051 args = args2;
4052
d2e4a39e 4053 if (choice == 0)
323e0a4a 4054 error (_("cancelled"));
14f9c5c9
AS
4055
4056 if (choice < first_choice)
4c4b4cd2
PH
4057 {
4058 n_chosen = n_choices;
4059 for (j = 0; j < n_choices; j += 1)
4060 choices[j] = j;
4061 break;
4062 }
14f9c5c9
AS
4063 choice -= first_choice;
4064
d2e4a39e 4065 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4066 {
4067 }
14f9c5c9
AS
4068
4069 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4070 {
4071 int k;
5b4ee69b 4072
4c4b4cd2
PH
4073 for (k = n_chosen - 1; k > j; k -= 1)
4074 choices[k + 1] = choices[k];
4075 choices[j + 1] = choice;
4076 n_chosen += 1;
4077 }
14f9c5c9
AS
4078 }
4079
4080 if (n_chosen > max_results)
323e0a4a 4081 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4082
14f9c5c9
AS
4083 return n_chosen;
4084}
4085
4c4b4cd2
PH
4086/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4087 on the function identified by SYM and BLOCK, and taking NARGS
4088 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4089
4090static void
e9d9f57e 4091replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4092 int oplen, struct symbol *sym,
270140bd 4093 const struct block *block)
14f9c5c9
AS
4094{
4095 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4096 symbol, -oplen for operator being replaced). */
d2e4a39e 4097 struct expression *newexp = (struct expression *)
8c1a34e7 4098 xzalloc (sizeof (struct expression)
4c4b4cd2 4099 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4100 struct expression *exp = expp->get ();
14f9c5c9
AS
4101
4102 newexp->nelts = exp->nelts + 7 - oplen;
4103 newexp->language_defn = exp->language_defn;
3489610d 4104 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4105 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4106 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4107 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4108
4109 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4110 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4111
4112 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4113 newexp->elts[pc + 4].block = block;
4114 newexp->elts[pc + 5].symbol = sym;
4115
e9d9f57e 4116 expp->reset (newexp);
d2e4a39e 4117}
14f9c5c9
AS
4118
4119/* Type-class predicates */
4120
4c4b4cd2
PH
4121/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4122 or FLOAT). */
14f9c5c9
AS
4123
4124static int
d2e4a39e 4125numeric_type_p (struct type *type)
14f9c5c9
AS
4126{
4127 if (type == NULL)
4128 return 0;
d2e4a39e
AS
4129 else
4130 {
4131 switch (TYPE_CODE (type))
4c4b4cd2
PH
4132 {
4133 case TYPE_CODE_INT:
4134 case TYPE_CODE_FLT:
4135 return 1;
4136 case TYPE_CODE_RANGE:
4137 return (type == TYPE_TARGET_TYPE (type)
4138 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4139 default:
4140 return 0;
4141 }
d2e4a39e 4142 }
14f9c5c9
AS
4143}
4144
4c4b4cd2 4145/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4146
4147static int
d2e4a39e 4148integer_type_p (struct type *type)
14f9c5c9
AS
4149{
4150 if (type == NULL)
4151 return 0;
d2e4a39e
AS
4152 else
4153 {
4154 switch (TYPE_CODE (type))
4c4b4cd2
PH
4155 {
4156 case TYPE_CODE_INT:
4157 return 1;
4158 case TYPE_CODE_RANGE:
4159 return (type == TYPE_TARGET_TYPE (type)
4160 || integer_type_p (TYPE_TARGET_TYPE (type)));
4161 default:
4162 return 0;
4163 }
d2e4a39e 4164 }
14f9c5c9
AS
4165}
4166
4c4b4cd2 4167/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4168
4169static int
d2e4a39e 4170scalar_type_p (struct type *type)
14f9c5c9
AS
4171{
4172 if (type == NULL)
4173 return 0;
d2e4a39e
AS
4174 else
4175 {
4176 switch (TYPE_CODE (type))
4c4b4cd2
PH
4177 {
4178 case TYPE_CODE_INT:
4179 case TYPE_CODE_RANGE:
4180 case TYPE_CODE_ENUM:
4181 case TYPE_CODE_FLT:
4182 return 1;
4183 default:
4184 return 0;
4185 }
d2e4a39e 4186 }
14f9c5c9
AS
4187}
4188
4c4b4cd2 4189/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4190
4191static int
d2e4a39e 4192discrete_type_p (struct type *type)
14f9c5c9
AS
4193{
4194 if (type == NULL)
4195 return 0;
d2e4a39e
AS
4196 else
4197 {
4198 switch (TYPE_CODE (type))
4c4b4cd2
PH
4199 {
4200 case TYPE_CODE_INT:
4201 case TYPE_CODE_RANGE:
4202 case TYPE_CODE_ENUM:
872f0337 4203 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4204 return 1;
4205 default:
4206 return 0;
4207 }
d2e4a39e 4208 }
14f9c5c9
AS
4209}
4210
4c4b4cd2
PH
4211/* Returns non-zero if OP with operands in the vector ARGS could be
4212 a user-defined function. Errs on the side of pre-defined operators
4213 (i.e., result 0). */
14f9c5c9
AS
4214
4215static int
d2e4a39e 4216possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4217{
76a01679 4218 struct type *type0 =
df407dfe 4219 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4220 struct type *type1 =
df407dfe 4221 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4222
4c4b4cd2
PH
4223 if (type0 == NULL)
4224 return 0;
4225
14f9c5c9
AS
4226 switch (op)
4227 {
4228 default:
4229 return 0;
4230
4231 case BINOP_ADD:
4232 case BINOP_SUB:
4233 case BINOP_MUL:
4234 case BINOP_DIV:
d2e4a39e 4235 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4236
4237 case BINOP_REM:
4238 case BINOP_MOD:
4239 case BINOP_BITWISE_AND:
4240 case BINOP_BITWISE_IOR:
4241 case BINOP_BITWISE_XOR:
d2e4a39e 4242 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4243
4244 case BINOP_EQUAL:
4245 case BINOP_NOTEQUAL:
4246 case BINOP_LESS:
4247 case BINOP_GTR:
4248 case BINOP_LEQ:
4249 case BINOP_GEQ:
d2e4a39e 4250 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4251
4252 case BINOP_CONCAT:
ee90b9ab 4253 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4254
4255 case BINOP_EXP:
d2e4a39e 4256 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4257
4258 case UNOP_NEG:
4259 case UNOP_PLUS:
4260 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4261 case UNOP_ABS:
4262 return (!numeric_type_p (type0));
14f9c5c9
AS
4263
4264 }
4265}
4266\f
4c4b4cd2 4267 /* Renaming */
14f9c5c9 4268
aeb5907d
JB
4269/* NOTES:
4270
4271 1. In the following, we assume that a renaming type's name may
4272 have an ___XD suffix. It would be nice if this went away at some
4273 point.
4274 2. We handle both the (old) purely type-based representation of
4275 renamings and the (new) variable-based encoding. At some point,
4276 it is devoutly to be hoped that the former goes away
4277 (FIXME: hilfinger-2007-07-09).
4278 3. Subprogram renamings are not implemented, although the XRS
4279 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4280
4281/* If SYM encodes a renaming,
4282
4283 <renaming> renames <renamed entity>,
4284
4285 sets *LEN to the length of the renamed entity's name,
4286 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4287 the string describing the subcomponent selected from the renamed
0963b4bd 4288 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4289 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4290 are undefined). Otherwise, returns a value indicating the category
4291 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4292 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4293 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4294 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4295 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4296 may be NULL, in which case they are not assigned.
4297
4298 [Currently, however, GCC does not generate subprogram renamings.] */
4299
4300enum ada_renaming_category
4301ada_parse_renaming (struct symbol *sym,
4302 const char **renamed_entity, int *len,
4303 const char **renaming_expr)
4304{
4305 enum ada_renaming_category kind;
4306 const char *info;
4307 const char *suffix;
4308
4309 if (sym == NULL)
4310 return ADA_NOT_RENAMING;
4311 switch (SYMBOL_CLASS (sym))
14f9c5c9 4312 {
aeb5907d
JB
4313 default:
4314 return ADA_NOT_RENAMING;
4315 case LOC_TYPEDEF:
4316 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4317 renamed_entity, len, renaming_expr);
4318 case LOC_LOCAL:
4319 case LOC_STATIC:
4320 case LOC_COMPUTED:
4321 case LOC_OPTIMIZED_OUT:
4322 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4323 if (info == NULL)
4324 return ADA_NOT_RENAMING;
4325 switch (info[5])
4326 {
4327 case '_':
4328 kind = ADA_OBJECT_RENAMING;
4329 info += 6;
4330 break;
4331 case 'E':
4332 kind = ADA_EXCEPTION_RENAMING;
4333 info += 7;
4334 break;
4335 case 'P':
4336 kind = ADA_PACKAGE_RENAMING;
4337 info += 7;
4338 break;
4339 case 'S':
4340 kind = ADA_SUBPROGRAM_RENAMING;
4341 info += 7;
4342 break;
4343 default:
4344 return ADA_NOT_RENAMING;
4345 }
14f9c5c9 4346 }
4c4b4cd2 4347
aeb5907d
JB
4348 if (renamed_entity != NULL)
4349 *renamed_entity = info;
4350 suffix = strstr (info, "___XE");
4351 if (suffix == NULL || suffix == info)
4352 return ADA_NOT_RENAMING;
4353 if (len != NULL)
4354 *len = strlen (info) - strlen (suffix);
4355 suffix += 5;
4356 if (renaming_expr != NULL)
4357 *renaming_expr = suffix;
4358 return kind;
4359}
4360
4361/* Assuming TYPE encodes a renaming according to the old encoding in
4362 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4363 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4364 ADA_NOT_RENAMING otherwise. */
4365static enum ada_renaming_category
4366parse_old_style_renaming (struct type *type,
4367 const char **renamed_entity, int *len,
4368 const char **renaming_expr)
4369{
4370 enum ada_renaming_category kind;
4371 const char *name;
4372 const char *info;
4373 const char *suffix;
14f9c5c9 4374
aeb5907d
JB
4375 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4376 || TYPE_NFIELDS (type) != 1)
4377 return ADA_NOT_RENAMING;
14f9c5c9 4378
a737d952 4379 name = TYPE_NAME (type);
aeb5907d
JB
4380 if (name == NULL)
4381 return ADA_NOT_RENAMING;
4382
4383 name = strstr (name, "___XR");
4384 if (name == NULL)
4385 return ADA_NOT_RENAMING;
4386 switch (name[5])
4387 {
4388 case '\0':
4389 case '_':
4390 kind = ADA_OBJECT_RENAMING;
4391 break;
4392 case 'E':
4393 kind = ADA_EXCEPTION_RENAMING;
4394 break;
4395 case 'P':
4396 kind = ADA_PACKAGE_RENAMING;
4397 break;
4398 case 'S':
4399 kind = ADA_SUBPROGRAM_RENAMING;
4400 break;
4401 default:
4402 return ADA_NOT_RENAMING;
4403 }
14f9c5c9 4404
aeb5907d
JB
4405 info = TYPE_FIELD_NAME (type, 0);
4406 if (info == NULL)
4407 return ADA_NOT_RENAMING;
4408 if (renamed_entity != NULL)
4409 *renamed_entity = info;
4410 suffix = strstr (info, "___XE");
4411 if (renaming_expr != NULL)
4412 *renaming_expr = suffix + 5;
4413 if (suffix == NULL || suffix == info)
4414 return ADA_NOT_RENAMING;
4415 if (len != NULL)
4416 *len = suffix - info;
4417 return kind;
a5ee536b
JB
4418}
4419
4420/* Compute the value of the given RENAMING_SYM, which is expected to
4421 be a symbol encoding a renaming expression. BLOCK is the block
4422 used to evaluate the renaming. */
52ce6436 4423
a5ee536b
JB
4424static struct value *
4425ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4426 const struct block *block)
a5ee536b 4427{
bbc13ae3 4428 const char *sym_name;
a5ee536b 4429
bbc13ae3 4430 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4431 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4432 return evaluate_expression (expr.get ());
a5ee536b 4433}
14f9c5c9 4434\f
d2e4a39e 4435
4c4b4cd2 4436 /* Evaluation: Function Calls */
14f9c5c9 4437
4c4b4cd2 4438/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4439 lvalues, and otherwise has the side-effect of allocating memory
4440 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4441
d2e4a39e 4442static struct value *
40bc484c 4443ensure_lval (struct value *val)
14f9c5c9 4444{
40bc484c
JB
4445 if (VALUE_LVAL (val) == not_lval
4446 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4447 {
df407dfe 4448 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4449 const CORE_ADDR addr =
4450 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4451
a84a8a0d 4452 VALUE_LVAL (val) = lval_memory;
1a088441 4453 set_value_address (val, addr);
40bc484c 4454 write_memory (addr, value_contents (val), len);
c3e5cd34 4455 }
14f9c5c9
AS
4456
4457 return val;
4458}
4459
4460/* Return the value ACTUAL, converted to be an appropriate value for a
4461 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4462 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4463 values not residing in memory, updating it as needed. */
14f9c5c9 4464
a93c0eb6 4465struct value *
40bc484c 4466ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4467{
df407dfe 4468 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4469 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4470 struct type *formal_target =
4471 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4472 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4473 struct type *actual_target =
4474 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4475 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4476
4c4b4cd2 4477 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4478 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4479 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4480 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4481 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4482 {
a84a8a0d 4483 struct value *result;
5b4ee69b 4484
14f9c5c9 4485 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4486 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4487 result = desc_data (actual);
cb923fcc 4488 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4489 {
4490 if (VALUE_LVAL (actual) != lval_memory)
4491 {
4492 struct value *val;
5b4ee69b 4493
df407dfe 4494 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4495 val = allocate_value (actual_type);
990a07ab 4496 memcpy ((char *) value_contents_raw (val),
0fd88904 4497 (char *) value_contents (actual),
4c4b4cd2 4498 TYPE_LENGTH (actual_type));
40bc484c 4499 actual = ensure_lval (val);
4c4b4cd2 4500 }
a84a8a0d 4501 result = value_addr (actual);
4c4b4cd2 4502 }
a84a8a0d
JB
4503 else
4504 return actual;
b1af9e97 4505 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4506 }
4507 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4508 return ada_value_ind (actual);
8344af1e
JB
4509 else if (ada_is_aligner_type (formal_type))
4510 {
4511 /* We need to turn this parameter into an aligner type
4512 as well. */
4513 struct value *aligner = allocate_value (formal_type);
4514 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4515
4516 value_assign_to_component (aligner, component, actual);
4517 return aligner;
4518 }
14f9c5c9
AS
4519
4520 return actual;
4521}
4522
438c98a1
JB
4523/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4524 type TYPE. This is usually an inefficient no-op except on some targets
4525 (such as AVR) where the representation of a pointer and an address
4526 differs. */
4527
4528static CORE_ADDR
4529value_pointer (struct value *value, struct type *type)
4530{
4531 struct gdbarch *gdbarch = get_type_arch (type);
4532 unsigned len = TYPE_LENGTH (type);
224c3ddb 4533 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4534 CORE_ADDR addr;
4535
4536 addr = value_address (value);
4537 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4538 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4539 return addr;
4540}
4541
14f9c5c9 4542
4c4b4cd2
PH
4543/* Push a descriptor of type TYPE for array value ARR on the stack at
4544 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4545 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4546 to-descriptor type rather than a descriptor type), a struct value *
4547 representing a pointer to this descriptor. */
14f9c5c9 4548
d2e4a39e 4549static struct value *
40bc484c 4550make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4551{
d2e4a39e
AS
4552 struct type *bounds_type = desc_bounds_type (type);
4553 struct type *desc_type = desc_base_type (type);
4554 struct value *descriptor = allocate_value (desc_type);
4555 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4556 int i;
d2e4a39e 4557
0963b4bd
MS
4558 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4559 i > 0; i -= 1)
14f9c5c9 4560 {
19f220c3
JK
4561 modify_field (value_type (bounds), value_contents_writeable (bounds),
4562 ada_array_bound (arr, i, 0),
4563 desc_bound_bitpos (bounds_type, i, 0),
4564 desc_bound_bitsize (bounds_type, i, 0));
4565 modify_field (value_type (bounds), value_contents_writeable (bounds),
4566 ada_array_bound (arr, i, 1),
4567 desc_bound_bitpos (bounds_type, i, 1),
4568 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4569 }
d2e4a39e 4570
40bc484c 4571 bounds = ensure_lval (bounds);
d2e4a39e 4572
19f220c3
JK
4573 modify_field (value_type (descriptor),
4574 value_contents_writeable (descriptor),
4575 value_pointer (ensure_lval (arr),
4576 TYPE_FIELD_TYPE (desc_type, 0)),
4577 fat_pntr_data_bitpos (desc_type),
4578 fat_pntr_data_bitsize (desc_type));
4579
4580 modify_field (value_type (descriptor),
4581 value_contents_writeable (descriptor),
4582 value_pointer (bounds,
4583 TYPE_FIELD_TYPE (desc_type, 1)),
4584 fat_pntr_bounds_bitpos (desc_type),
4585 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4586
40bc484c 4587 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4588
4589 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4590 return value_addr (descriptor);
4591 else
4592 return descriptor;
4593}
14f9c5c9 4594\f
3d9434b5
JB
4595 /* Symbol Cache Module */
4596
3d9434b5 4597/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4598 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4599 on the type of entity being printed, the cache can make it as much
4600 as an order of magnitude faster than without it.
4601
4602 The descriptive type DWARF extension has significantly reduced
4603 the need for this cache, at least when DWARF is being used. However,
4604 even in this case, some expensive name-based symbol searches are still
4605 sometimes necessary - to find an XVZ variable, mostly. */
4606
ee01b665 4607/* Initialize the contents of SYM_CACHE. */
3d9434b5 4608
ee01b665
JB
4609static void
4610ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4611{
4612 obstack_init (&sym_cache->cache_space);
4613 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4614}
3d9434b5 4615
ee01b665
JB
4616/* Free the memory used by SYM_CACHE. */
4617
4618static void
4619ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4620{
ee01b665
JB
4621 obstack_free (&sym_cache->cache_space, NULL);
4622 xfree (sym_cache);
4623}
3d9434b5 4624
ee01b665
JB
4625/* Return the symbol cache associated to the given program space PSPACE.
4626 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4627
ee01b665
JB
4628static struct ada_symbol_cache *
4629ada_get_symbol_cache (struct program_space *pspace)
4630{
4631 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4632
66c168ae 4633 if (pspace_data->sym_cache == NULL)
ee01b665 4634 {
66c168ae
JB
4635 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4636 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4637 }
4638
66c168ae 4639 return pspace_data->sym_cache;
ee01b665 4640}
3d9434b5
JB
4641
4642/* Clear all entries from the symbol cache. */
4643
4644static void
4645ada_clear_symbol_cache (void)
4646{
ee01b665
JB
4647 struct ada_symbol_cache *sym_cache
4648 = ada_get_symbol_cache (current_program_space);
4649
4650 obstack_free (&sym_cache->cache_space, NULL);
4651 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4652}
4653
fe978cb0 4654/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4655 Return it if found, or NULL otherwise. */
4656
4657static struct cache_entry **
fe978cb0 4658find_entry (const char *name, domain_enum domain)
3d9434b5 4659{
ee01b665
JB
4660 struct ada_symbol_cache *sym_cache
4661 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4662 int h = msymbol_hash (name) % HASH_SIZE;
4663 struct cache_entry **e;
4664
ee01b665 4665 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4666 {
fe978cb0 4667 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4668 return e;
4669 }
4670 return NULL;
4671}
4672
fe978cb0 4673/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4674 Return 1 if found, 0 otherwise.
4675
4676 If an entry was found and SYM is not NULL, set *SYM to the entry's
4677 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4678
96d887e8 4679static int
fe978cb0 4680lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4681 struct symbol **sym, const struct block **block)
96d887e8 4682{
fe978cb0 4683 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4684
4685 if (e == NULL)
4686 return 0;
4687 if (sym != NULL)
4688 *sym = (*e)->sym;
4689 if (block != NULL)
4690 *block = (*e)->block;
4691 return 1;
96d887e8
PH
4692}
4693
3d9434b5 4694/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4695 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4696
96d887e8 4697static void
fe978cb0 4698cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4699 const struct block *block)
96d887e8 4700{
ee01b665
JB
4701 struct ada_symbol_cache *sym_cache
4702 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4703 int h;
4704 char *copy;
4705 struct cache_entry *e;
4706
1994afbf
DE
4707 /* Symbols for builtin types don't have a block.
4708 For now don't cache such symbols. */
4709 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4710 return;
4711
3d9434b5
JB
4712 /* If the symbol is a local symbol, then do not cache it, as a search
4713 for that symbol depends on the context. To determine whether
4714 the symbol is local or not, we check the block where we found it
4715 against the global and static blocks of its associated symtab. */
4716 if (sym
08be3fe3 4717 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4718 GLOBAL_BLOCK) != block
08be3fe3 4719 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4720 STATIC_BLOCK) != block)
3d9434b5
JB
4721 return;
4722
4723 h = msymbol_hash (name) % HASH_SIZE;
e39db4db 4724 e = XOBNEW (&sym_cache->cache_space, cache_entry);
ee01b665
JB
4725 e->next = sym_cache->root[h];
4726 sym_cache->root[h] = e;
224c3ddb
SM
4727 e->name = copy
4728 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4729 strcpy (copy, name);
4730 e->sym = sym;
fe978cb0 4731 e->domain = domain;
3d9434b5 4732 e->block = block;
96d887e8 4733}
4c4b4cd2
PH
4734\f
4735 /* Symbol Lookup */
4736
b5ec771e
PA
4737/* Return the symbol name match type that should be used used when
4738 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4739
4740 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4741 for Ada lookups. */
c0431670 4742
b5ec771e
PA
4743static symbol_name_match_type
4744name_match_type_from_name (const char *lookup_name)
c0431670 4745{
b5ec771e
PA
4746 return (strstr (lookup_name, "__") == NULL
4747 ? symbol_name_match_type::WILD
4748 : symbol_name_match_type::FULL);
c0431670
JB
4749}
4750
4c4b4cd2
PH
4751/* Return the result of a standard (literal, C-like) lookup of NAME in
4752 given DOMAIN, visible from lexical block BLOCK. */
4753
4754static struct symbol *
4755standard_lookup (const char *name, const struct block *block,
4756 domain_enum domain)
4757{
acbd605d 4758 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4759 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4760
d12307c1
PMR
4761 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4762 return sym.symbol;
2570f2b7 4763 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4764 cache_symbol (name, domain, sym.symbol, sym.block);
4765 return sym.symbol;
4c4b4cd2
PH
4766}
4767
4768
4769/* Non-zero iff there is at least one non-function/non-enumeral symbol
4770 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4771 since they contend in overloading in the same way. */
4772static int
d12307c1 4773is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4774{
4775 int i;
4776
4777 for (i = 0; i < n; i += 1)
d12307c1
PMR
4778 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4779 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4780 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4781 return 1;
4782
4783 return 0;
4784}
4785
4786/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4787 struct types. Otherwise, they may not. */
14f9c5c9
AS
4788
4789static int
d2e4a39e 4790equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4791{
d2e4a39e 4792 if (type0 == type1)
14f9c5c9 4793 return 1;
d2e4a39e 4794 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4795 || TYPE_CODE (type0) != TYPE_CODE (type1))
4796 return 0;
d2e4a39e 4797 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4798 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4799 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4800 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4801 return 1;
d2e4a39e 4802
14f9c5c9
AS
4803 return 0;
4804}
4805
4806/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4807 no more defined than that of SYM1. */
14f9c5c9
AS
4808
4809static int
d2e4a39e 4810lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4811{
4812 if (sym0 == sym1)
4813 return 1;
176620f1 4814 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4815 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4816 return 0;
4817
d2e4a39e 4818 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4819 {
4820 case LOC_UNDEF:
4821 return 1;
4822 case LOC_TYPEDEF:
4823 {
4c4b4cd2
PH
4824 struct type *type0 = SYMBOL_TYPE (sym0);
4825 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4826 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4827 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4828 int len0 = strlen (name0);
5b4ee69b 4829
4c4b4cd2
PH
4830 return
4831 TYPE_CODE (type0) == TYPE_CODE (type1)
4832 && (equiv_types (type0, type1)
4833 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4834 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4835 }
4836 case LOC_CONST:
4837 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4838 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4839 default:
4840 return 0;
14f9c5c9
AS
4841 }
4842}
4843
d12307c1 4844/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4845 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4846
4847static void
76a01679
JB
4848add_defn_to_vec (struct obstack *obstackp,
4849 struct symbol *sym,
f0c5f9b2 4850 const struct block *block)
14f9c5c9
AS
4851{
4852 int i;
d12307c1 4853 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4854
529cad9c
PH
4855 /* Do not try to complete stub types, as the debugger is probably
4856 already scanning all symbols matching a certain name at the
4857 time when this function is called. Trying to replace the stub
4858 type by its associated full type will cause us to restart a scan
4859 which may lead to an infinite recursion. Instead, the client
4860 collecting the matching symbols will end up collecting several
4861 matches, with at least one of them complete. It can then filter
4862 out the stub ones if needed. */
4863
4c4b4cd2
PH
4864 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4865 {
d12307c1 4866 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4867 return;
d12307c1 4868 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4869 {
d12307c1 4870 prevDefns[i].symbol = sym;
4c4b4cd2 4871 prevDefns[i].block = block;
4c4b4cd2 4872 return;
76a01679 4873 }
4c4b4cd2
PH
4874 }
4875
4876 {
d12307c1 4877 struct block_symbol info;
4c4b4cd2 4878
d12307c1 4879 info.symbol = sym;
4c4b4cd2 4880 info.block = block;
d12307c1 4881 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4882 }
4883}
4884
d12307c1
PMR
4885/* Number of block_symbol structures currently collected in current vector in
4886 OBSTACKP. */
4c4b4cd2 4887
76a01679
JB
4888static int
4889num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4890{
d12307c1 4891 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4892}
4893
d12307c1
PMR
4894/* Vector of block_symbol structures currently collected in current vector in
4895 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4896
d12307c1 4897static struct block_symbol *
4c4b4cd2
PH
4898defns_collected (struct obstack *obstackp, int finish)
4899{
4900 if (finish)
224c3ddb 4901 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4902 else
d12307c1 4903 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4904}
4905
7c7b6655
TT
4906/* Return a bound minimal symbol matching NAME according to Ada
4907 decoding rules. Returns an invalid symbol if there is no such
4908 minimal symbol. Names prefixed with "standard__" are handled
4909 specially: "standard__" is first stripped off, and only static and
4910 global symbols are searched. */
4c4b4cd2 4911
7c7b6655 4912struct bound_minimal_symbol
96d887e8 4913ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4914{
7c7b6655 4915 struct bound_minimal_symbol result;
4c4b4cd2 4916
7c7b6655
TT
4917 memset (&result, 0, sizeof (result));
4918
b5ec771e
PA
4919 symbol_name_match_type match_type = name_match_type_from_name (name);
4920 lookup_name_info lookup_name (name, match_type);
4921
4922 symbol_name_matcher_ftype *match_name
4923 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4924
2030c079 4925 for (objfile *objfile : current_program_space->objfiles ())
5325b9bf
TT
4926 {
4927 for (minimal_symbol *msymbol : objfile_msymbols (objfile))
4928 {
4929 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4930 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4931 {
4932 result.minsym = msymbol;
4933 result.objfile = objfile;
4934 break;
4935 }
4936 }
4937 }
4c4b4cd2 4938
7c7b6655 4939 return result;
96d887e8 4940}
4c4b4cd2 4941
96d887e8
PH
4942/* For all subprograms that statically enclose the subprogram of the
4943 selected frame, add symbols matching identifier NAME in DOMAIN
4944 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4945 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4946 with a wildcard prefix. */
4c4b4cd2 4947
96d887e8
PH
4948static void
4949add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4950 const lookup_name_info &lookup_name,
4951 domain_enum domain)
96d887e8 4952{
96d887e8 4953}
14f9c5c9 4954
96d887e8
PH
4955/* True if TYPE is definitely an artificial type supplied to a symbol
4956 for which no debugging information was given in the symbol file. */
14f9c5c9 4957
96d887e8
PH
4958static int
4959is_nondebugging_type (struct type *type)
4960{
0d5cff50 4961 const char *name = ada_type_name (type);
5b4ee69b 4962
96d887e8
PH
4963 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4964}
4c4b4cd2 4965
8f17729f
JB
4966/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4967 that are deemed "identical" for practical purposes.
4968
4969 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4970 types and that their number of enumerals is identical (in other
4971 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4972
4973static int
4974ada_identical_enum_types_p (struct type *type1, struct type *type2)
4975{
4976 int i;
4977
4978 /* The heuristic we use here is fairly conservative. We consider
4979 that 2 enumerate types are identical if they have the same
4980 number of enumerals and that all enumerals have the same
4981 underlying value and name. */
4982
4983 /* All enums in the type should have an identical underlying value. */
4984 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4985 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4986 return 0;
4987
4988 /* All enumerals should also have the same name (modulo any numerical
4989 suffix). */
4990 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4991 {
0d5cff50
DE
4992 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4993 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4994 int len_1 = strlen (name_1);
4995 int len_2 = strlen (name_2);
4996
4997 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4998 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4999 if (len_1 != len_2
5000 || strncmp (TYPE_FIELD_NAME (type1, i),
5001 TYPE_FIELD_NAME (type2, i),
5002 len_1) != 0)
5003 return 0;
5004 }
5005
5006 return 1;
5007}
5008
5009/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5010 that are deemed "identical" for practical purposes. Sometimes,
5011 enumerals are not strictly identical, but their types are so similar
5012 that they can be considered identical.
5013
5014 For instance, consider the following code:
5015
5016 type Color is (Black, Red, Green, Blue, White);
5017 type RGB_Color is new Color range Red .. Blue;
5018
5019 Type RGB_Color is a subrange of an implicit type which is a copy
5020 of type Color. If we call that implicit type RGB_ColorB ("B" is
5021 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5022 As a result, when an expression references any of the enumeral
5023 by name (Eg. "print green"), the expression is technically
5024 ambiguous and the user should be asked to disambiguate. But
5025 doing so would only hinder the user, since it wouldn't matter
5026 what choice he makes, the outcome would always be the same.
5027 So, for practical purposes, we consider them as the same. */
5028
5029static int
54d343a2 5030symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
5031{
5032 int i;
5033
5034 /* Before performing a thorough comparison check of each type,
5035 we perform a series of inexpensive checks. We expect that these
5036 checks will quickly fail in the vast majority of cases, and thus
5037 help prevent the unnecessary use of a more expensive comparison.
5038 Said comparison also expects us to make some of these checks
5039 (see ada_identical_enum_types_p). */
5040
5041 /* Quick check: All symbols should have an enum type. */
54d343a2 5042 for (i = 0; i < syms.size (); i++)
d12307c1 5043 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5044 return 0;
5045
5046 /* Quick check: They should all have the same value. */
54d343a2 5047 for (i = 1; i < syms.size (); i++)
d12307c1 5048 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5049 return 0;
5050
5051 /* Quick check: They should all have the same number of enumerals. */
54d343a2 5052 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5053 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5054 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5055 return 0;
5056
5057 /* All the sanity checks passed, so we might have a set of
5058 identical enumeration types. Perform a more complete
5059 comparison of the type of each symbol. */
54d343a2 5060 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5061 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5062 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5063 return 0;
5064
5065 return 1;
5066}
5067
54d343a2 5068/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
5069 duplicate other symbols in the list (The only case I know of where
5070 this happens is when object files containing stabs-in-ecoff are
5071 linked with files containing ordinary ecoff debugging symbols (or no
5072 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5073 Returns the number of items in the modified list. */
4c4b4cd2 5074
96d887e8 5075static int
54d343a2 5076remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5077{
5078 int i, j;
4c4b4cd2 5079
8f17729f
JB
5080 /* We should never be called with less than 2 symbols, as there
5081 cannot be any extra symbol in that case. But it's easy to
5082 handle, since we have nothing to do in that case. */
54d343a2
TT
5083 if (syms->size () < 2)
5084 return syms->size ();
8f17729f 5085
96d887e8 5086 i = 0;
54d343a2 5087 while (i < syms->size ())
96d887e8 5088 {
a35ddb44 5089 int remove_p = 0;
339c13b6
JB
5090
5091 /* If two symbols have the same name and one of them is a stub type,
5092 the get rid of the stub. */
5093
54d343a2
TT
5094 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5095 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5096 {
54d343a2 5097 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5098 {
5099 if (j != i
54d343a2
TT
5100 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5101 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5102 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5103 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5104 remove_p = 1;
339c13b6
JB
5105 }
5106 }
5107
5108 /* Two symbols with the same name, same class and same address
5109 should be identical. */
5110
54d343a2
TT
5111 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5112 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5113 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5114 {
54d343a2 5115 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5116 {
5117 if (i != j
54d343a2
TT
5118 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5119 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5120 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5121 && SYMBOL_CLASS ((*syms)[i].symbol)
5122 == SYMBOL_CLASS ((*syms)[j].symbol)
5123 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5124 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5125 remove_p = 1;
4c4b4cd2 5126 }
4c4b4cd2 5127 }
339c13b6 5128
a35ddb44 5129 if (remove_p)
54d343a2 5130 syms->erase (syms->begin () + i);
339c13b6 5131
96d887e8 5132 i += 1;
14f9c5c9 5133 }
8f17729f
JB
5134
5135 /* If all the remaining symbols are identical enumerals, then
5136 just keep the first one and discard the rest.
5137
5138 Unlike what we did previously, we do not discard any entry
5139 unless they are ALL identical. This is because the symbol
5140 comparison is not a strict comparison, but rather a practical
5141 comparison. If all symbols are considered identical, then
5142 we can just go ahead and use the first one and discard the rest.
5143 But if we cannot reduce the list to a single element, we have
5144 to ask the user to disambiguate anyways. And if we have to
5145 present a multiple-choice menu, it's less confusing if the list
5146 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5147 if (symbols_are_identical_enums (*syms))
5148 syms->resize (1);
8f17729f 5149
54d343a2 5150 return syms->size ();
14f9c5c9
AS
5151}
5152
96d887e8
PH
5153/* Given a type that corresponds to a renaming entity, use the type name
5154 to extract the scope (package name or function name, fully qualified,
5155 and following the GNAT encoding convention) where this renaming has been
49d83361 5156 defined. */
4c4b4cd2 5157
49d83361 5158static std::string
96d887e8 5159xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5160{
96d887e8 5161 /* The renaming types adhere to the following convention:
0963b4bd 5162 <scope>__<rename>___<XR extension>.
96d887e8
PH
5163 So, to extract the scope, we search for the "___XR" extension,
5164 and then backtrack until we find the first "__". */
76a01679 5165
a737d952 5166 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5167 const char *suffix = strstr (name, "___XR");
5168 const char *last;
14f9c5c9 5169
96d887e8
PH
5170 /* Now, backtrack a bit until we find the first "__". Start looking
5171 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5172
96d887e8
PH
5173 for (last = suffix - 3; last > name; last--)
5174 if (last[0] == '_' && last[1] == '_')
5175 break;
76a01679 5176
96d887e8 5177 /* Make a copy of scope and return it. */
49d83361 5178 return std::string (name, last);
4c4b4cd2
PH
5179}
5180
96d887e8 5181/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5182
96d887e8
PH
5183static int
5184is_package_name (const char *name)
4c4b4cd2 5185{
96d887e8
PH
5186 /* Here, We take advantage of the fact that no symbols are generated
5187 for packages, while symbols are generated for each function.
5188 So the condition for NAME represent a package becomes equivalent
5189 to NAME not existing in our list of symbols. There is only one
5190 small complication with library-level functions (see below). */
4c4b4cd2 5191
96d887e8
PH
5192 /* If it is a function that has not been defined at library level,
5193 then we should be able to look it up in the symbols. */
5194 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5195 return 0;
14f9c5c9 5196
96d887e8
PH
5197 /* Library-level function names start with "_ada_". See if function
5198 "_ada_" followed by NAME can be found. */
14f9c5c9 5199
96d887e8 5200 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5201 functions names cannot contain "__" in them. */
96d887e8
PH
5202 if (strstr (name, "__") != NULL)
5203 return 0;
4c4b4cd2 5204
528e1572 5205 std::string fun_name = string_printf ("_ada_%s", name);
14f9c5c9 5206
528e1572 5207 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
96d887e8 5208}
14f9c5c9 5209
96d887e8 5210/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5211 not visible from FUNCTION_NAME. */
14f9c5c9 5212
96d887e8 5213static int
0d5cff50 5214old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5215{
aeb5907d
JB
5216 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5217 return 0;
5218
49d83361 5219 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5220
96d887e8 5221 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5222 if (is_package_name (scope.c_str ()))
5223 return 0;
14f9c5c9 5224
96d887e8
PH
5225 /* Check that the rename is in the current function scope by checking
5226 that its name starts with SCOPE. */
76a01679 5227
96d887e8
PH
5228 /* If the function name starts with "_ada_", it means that it is
5229 a library-level function. Strip this prefix before doing the
5230 comparison, as the encoding for the renaming does not contain
5231 this prefix. */
61012eef 5232 if (startswith (function_name, "_ada_"))
96d887e8 5233 function_name += 5;
f26caa11 5234
49d83361 5235 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5236}
5237
aeb5907d
JB
5238/* Remove entries from SYMS that corresponds to a renaming entity that
5239 is not visible from the function associated with CURRENT_BLOCK or
5240 that is superfluous due to the presence of more specific renaming
5241 information. Places surviving symbols in the initial entries of
5242 SYMS and returns the number of surviving symbols.
96d887e8
PH
5243
5244 Rationale:
aeb5907d
JB
5245 First, in cases where an object renaming is implemented as a
5246 reference variable, GNAT may produce both the actual reference
5247 variable and the renaming encoding. In this case, we discard the
5248 latter.
5249
5250 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5251 entity. Unfortunately, STABS currently does not support the definition
5252 of types that are local to a given lexical block, so all renamings types
5253 are emitted at library level. As a consequence, if an application
5254 contains two renaming entities using the same name, and a user tries to
5255 print the value of one of these entities, the result of the ada symbol
5256 lookup will also contain the wrong renaming type.
f26caa11 5257
96d887e8
PH
5258 This function partially covers for this limitation by attempting to
5259 remove from the SYMS list renaming symbols that should be visible
5260 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5261 method with the current information available. The implementation
5262 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5263
5264 - When the user tries to print a rename in a function while there
5265 is another rename entity defined in a package: Normally, the
5266 rename in the function has precedence over the rename in the
5267 package, so the latter should be removed from the list. This is
5268 currently not the case.
5269
5270 - This function will incorrectly remove valid renames if
5271 the CURRENT_BLOCK corresponds to a function which symbol name
5272 has been changed by an "Export" pragma. As a consequence,
5273 the user will be unable to print such rename entities. */
4c4b4cd2 5274
14f9c5c9 5275static int
54d343a2
TT
5276remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5277 const struct block *current_block)
4c4b4cd2
PH
5278{
5279 struct symbol *current_function;
0d5cff50 5280 const char *current_function_name;
4c4b4cd2 5281 int i;
aeb5907d
JB
5282 int is_new_style_renaming;
5283
5284 /* If there is both a renaming foo___XR... encoded as a variable and
5285 a simple variable foo in the same block, discard the latter.
0963b4bd 5286 First, zero out such symbols, then compress. */
aeb5907d 5287 is_new_style_renaming = 0;
54d343a2 5288 for (i = 0; i < syms->size (); i += 1)
aeb5907d 5289 {
54d343a2
TT
5290 struct symbol *sym = (*syms)[i].symbol;
5291 const struct block *block = (*syms)[i].block;
aeb5907d
JB
5292 const char *name;
5293 const char *suffix;
5294
5295 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5296 continue;
5297 name = SYMBOL_LINKAGE_NAME (sym);
5298 suffix = strstr (name, "___XR");
5299
5300 if (suffix != NULL)
5301 {
5302 int name_len = suffix - name;
5303 int j;
5b4ee69b 5304
aeb5907d 5305 is_new_style_renaming = 1;
54d343a2
TT
5306 for (j = 0; j < syms->size (); j += 1)
5307 if (i != j && (*syms)[j].symbol != NULL
5308 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
aeb5907d 5309 name_len) == 0
54d343a2
TT
5310 && block == (*syms)[j].block)
5311 (*syms)[j].symbol = NULL;
aeb5907d
JB
5312 }
5313 }
5314 if (is_new_style_renaming)
5315 {
5316 int j, k;
5317
54d343a2
TT
5318 for (j = k = 0; j < syms->size (); j += 1)
5319 if ((*syms)[j].symbol != NULL)
aeb5907d 5320 {
54d343a2 5321 (*syms)[k] = (*syms)[j];
aeb5907d
JB
5322 k += 1;
5323 }
5324 return k;
5325 }
4c4b4cd2
PH
5326
5327 /* Extract the function name associated to CURRENT_BLOCK.
5328 Abort if unable to do so. */
76a01679 5329
4c4b4cd2 5330 if (current_block == NULL)
54d343a2 5331 return syms->size ();
76a01679 5332
7f0df278 5333 current_function = block_linkage_function (current_block);
4c4b4cd2 5334 if (current_function == NULL)
54d343a2 5335 return syms->size ();
4c4b4cd2
PH
5336
5337 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5338 if (current_function_name == NULL)
54d343a2 5339 return syms->size ();
4c4b4cd2
PH
5340
5341 /* Check each of the symbols, and remove it from the list if it is
5342 a type corresponding to a renaming that is out of the scope of
5343 the current block. */
5344
5345 i = 0;
54d343a2 5346 while (i < syms->size ())
4c4b4cd2 5347 {
54d343a2 5348 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
aeb5907d 5349 == ADA_OBJECT_RENAMING
54d343a2
TT
5350 && old_renaming_is_invisible ((*syms)[i].symbol,
5351 current_function_name))
5352 syms->erase (syms->begin () + i);
4c4b4cd2
PH
5353 else
5354 i += 1;
5355 }
5356
54d343a2 5357 return syms->size ();
4c4b4cd2
PH
5358}
5359
339c13b6
JB
5360/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5361 whose name and domain match NAME and DOMAIN respectively.
5362 If no match was found, then extend the search to "enclosing"
5363 routines (in other words, if we're inside a nested function,
5364 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5365 If WILD_MATCH_P is nonzero, perform the naming matching in
5366 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5367
5368 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5369
5370static void
b5ec771e
PA
5371ada_add_local_symbols (struct obstack *obstackp,
5372 const lookup_name_info &lookup_name,
5373 const struct block *block, domain_enum domain)
339c13b6
JB
5374{
5375 int block_depth = 0;
5376
5377 while (block != NULL)
5378 {
5379 block_depth += 1;
b5ec771e 5380 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5381
5382 /* If we found a non-function match, assume that's the one. */
5383 if (is_nonfunction (defns_collected (obstackp, 0),
5384 num_defns_collected (obstackp)))
5385 return;
5386
5387 block = BLOCK_SUPERBLOCK (block);
5388 }
5389
5390 /* If no luck so far, try to find NAME as a local symbol in some lexically
5391 enclosing subprogram. */
5392 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5393 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5394}
5395
ccefe4c4 5396/* An object of this type is used as the user_data argument when
40658b94 5397 calling the map_matching_symbols method. */
ccefe4c4 5398
40658b94 5399struct match_data
ccefe4c4 5400{
40658b94 5401 struct objfile *objfile;
ccefe4c4 5402 struct obstack *obstackp;
40658b94
PH
5403 struct symbol *arg_sym;
5404 int found_sym;
ccefe4c4
TT
5405};
5406
22cee43f 5407/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5408 to a list of symbols. DATA0 is a pointer to a struct match_data *
5409 containing the obstack that collects the symbol list, the file that SYM
5410 must come from, a flag indicating whether a non-argument symbol has
5411 been found in the current block, and the last argument symbol
5412 passed in SYM within the current block (if any). When SYM is null,
5413 marking the end of a block, the argument symbol is added if no
5414 other has been found. */
ccefe4c4 5415
40658b94
PH
5416static int
5417aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5418{
40658b94
PH
5419 struct match_data *data = (struct match_data *) data0;
5420
5421 if (sym == NULL)
5422 {
5423 if (!data->found_sym && data->arg_sym != NULL)
5424 add_defn_to_vec (data->obstackp,
5425 fixup_symbol_section (data->arg_sym, data->objfile),
5426 block);
5427 data->found_sym = 0;
5428 data->arg_sym = NULL;
5429 }
5430 else
5431 {
5432 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5433 return 0;
5434 else if (SYMBOL_IS_ARGUMENT (sym))
5435 data->arg_sym = sym;
5436 else
5437 {
5438 data->found_sym = 1;
5439 add_defn_to_vec (data->obstackp,
5440 fixup_symbol_section (sym, data->objfile),
5441 block);
5442 }
5443 }
5444 return 0;
5445}
5446
b5ec771e
PA
5447/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5448 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5449 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5450
5451static int
5452ada_add_block_renamings (struct obstack *obstackp,
5453 const struct block *block,
b5ec771e
PA
5454 const lookup_name_info &lookup_name,
5455 domain_enum domain)
22cee43f
PMR
5456{
5457 struct using_direct *renaming;
5458 int defns_mark = num_defns_collected (obstackp);
5459
b5ec771e
PA
5460 symbol_name_matcher_ftype *name_match
5461 = ada_get_symbol_name_matcher (lookup_name);
5462
22cee43f
PMR
5463 for (renaming = block_using (block);
5464 renaming != NULL;
5465 renaming = renaming->next)
5466 {
5467 const char *r_name;
22cee43f
PMR
5468
5469 /* Avoid infinite recursions: skip this renaming if we are actually
5470 already traversing it.
5471
5472 Currently, symbol lookup in Ada don't use the namespace machinery from
5473 C++/Fortran support: skip namespace imports that use them. */
5474 if (renaming->searched
5475 || (renaming->import_src != NULL
5476 && renaming->import_src[0] != '\0')
5477 || (renaming->import_dest != NULL
5478 && renaming->import_dest[0] != '\0'))
5479 continue;
5480 renaming->searched = 1;
5481
5482 /* TODO: here, we perform another name-based symbol lookup, which can
5483 pull its own multiple overloads. In theory, we should be able to do
5484 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5485 not a simple name. But in order to do this, we would need to enhance
5486 the DWARF reader to associate a symbol to this renaming, instead of a
5487 name. So, for now, we do something simpler: re-use the C++/Fortran
5488 namespace machinery. */
5489 r_name = (renaming->alias != NULL
5490 ? renaming->alias
5491 : renaming->declaration);
b5ec771e
PA
5492 if (name_match (r_name, lookup_name, NULL))
5493 {
5494 lookup_name_info decl_lookup_name (renaming->declaration,
5495 lookup_name.match_type ());
5496 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5497 1, NULL);
5498 }
22cee43f
PMR
5499 renaming->searched = 0;
5500 }
5501 return num_defns_collected (obstackp) != defns_mark;
5502}
5503
db230ce3
JB
5504/* Implements compare_names, but only applying the comparision using
5505 the given CASING. */
5b4ee69b 5506
40658b94 5507static int
db230ce3
JB
5508compare_names_with_case (const char *string1, const char *string2,
5509 enum case_sensitivity casing)
40658b94
PH
5510{
5511 while (*string1 != '\0' && *string2 != '\0')
5512 {
db230ce3
JB
5513 char c1, c2;
5514
40658b94
PH
5515 if (isspace (*string1) || isspace (*string2))
5516 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5517
5518 if (casing == case_sensitive_off)
5519 {
5520 c1 = tolower (*string1);
5521 c2 = tolower (*string2);
5522 }
5523 else
5524 {
5525 c1 = *string1;
5526 c2 = *string2;
5527 }
5528 if (c1 != c2)
40658b94 5529 break;
db230ce3 5530
40658b94
PH
5531 string1 += 1;
5532 string2 += 1;
5533 }
db230ce3 5534
40658b94
PH
5535 switch (*string1)
5536 {
5537 case '(':
5538 return strcmp_iw_ordered (string1, string2);
5539 case '_':
5540 if (*string2 == '\0')
5541 {
052874e8 5542 if (is_name_suffix (string1))
40658b94
PH
5543 return 0;
5544 else
1a1d5513 5545 return 1;
40658b94 5546 }
dbb8534f 5547 /* FALLTHROUGH */
40658b94
PH
5548 default:
5549 if (*string2 == '(')
5550 return strcmp_iw_ordered (string1, string2);
5551 else
db230ce3
JB
5552 {
5553 if (casing == case_sensitive_off)
5554 return tolower (*string1) - tolower (*string2);
5555 else
5556 return *string1 - *string2;
5557 }
40658b94 5558 }
ccefe4c4
TT
5559}
5560
db230ce3
JB
5561/* Compare STRING1 to STRING2, with results as for strcmp.
5562 Compatible with strcmp_iw_ordered in that...
5563
5564 strcmp_iw_ordered (STRING1, STRING2) <= 0
5565
5566 ... implies...
5567
5568 compare_names (STRING1, STRING2) <= 0
5569
5570 (they may differ as to what symbols compare equal). */
5571
5572static int
5573compare_names (const char *string1, const char *string2)
5574{
5575 int result;
5576
5577 /* Similar to what strcmp_iw_ordered does, we need to perform
5578 a case-insensitive comparison first, and only resort to
5579 a second, case-sensitive, comparison if the first one was
5580 not sufficient to differentiate the two strings. */
5581
5582 result = compare_names_with_case (string1, string2, case_sensitive_off);
5583 if (result == 0)
5584 result = compare_names_with_case (string1, string2, case_sensitive_on);
5585
5586 return result;
5587}
5588
b5ec771e
PA
5589/* Convenience function to get at the Ada encoded lookup name for
5590 LOOKUP_NAME, as a C string. */
5591
5592static const char *
5593ada_lookup_name (const lookup_name_info &lookup_name)
5594{
5595 return lookup_name.ada ().lookup_name ().c_str ();
5596}
5597
339c13b6 5598/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5599 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5600 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5601 symbols otherwise. */
339c13b6
JB
5602
5603static void
b5ec771e
PA
5604add_nonlocal_symbols (struct obstack *obstackp,
5605 const lookup_name_info &lookup_name,
5606 domain_enum domain, int global)
339c13b6 5607{
40658b94 5608 struct match_data data;
339c13b6 5609
6475f2fe 5610 memset (&data, 0, sizeof data);
ccefe4c4 5611 data.obstackp = obstackp;
339c13b6 5612
b5ec771e
PA
5613 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5614
2030c079 5615 for (objfile *objfile : current_program_space->objfiles ())
40658b94
PH
5616 {
5617 data.objfile = objfile;
5618
5619 if (is_wild_match)
b5ec771e
PA
5620 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5621 domain, global,
4186eb54 5622 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5623 symbol_name_match_type::WILD,
5624 NULL);
40658b94 5625 else
b5ec771e
PA
5626 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5627 domain, global,
4186eb54 5628 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5629 symbol_name_match_type::FULL,
5630 compare_names);
22cee43f 5631
592553c4 5632 for (compunit_symtab *cu : objfile_compunits (objfile))
22cee43f
PMR
5633 {
5634 const struct block *global_block
5635 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5636
b5ec771e
PA
5637 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5638 domain))
22cee43f
PMR
5639 data.found_sym = 1;
5640 }
40658b94
PH
5641 }
5642
5643 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5644 {
b5ec771e
PA
5645 const char *name = ada_lookup_name (lookup_name);
5646 std::string name1 = std::string ("<_ada_") + name + '>';
5647
2030c079 5648 for (objfile *objfile : current_program_space->objfiles ())
40658b94 5649 {
40658b94 5650 data.objfile = objfile;
b5ec771e
PA
5651 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5652 domain, global,
0963b4bd
MS
5653 aux_add_nonlocal_symbols,
5654 &data,
b5ec771e
PA
5655 symbol_name_match_type::FULL,
5656 compare_names);
40658b94
PH
5657 }
5658 }
339c13b6
JB
5659}
5660
b5ec771e
PA
5661/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5662 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5663 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5664
22cee43f
PMR
5665 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5666 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5667 is the one match returned (no other matches in that or
d9680e73 5668 enclosing blocks is returned). If there are any matches in or
22cee43f 5669 surrounding BLOCK, then these alone are returned.
4eeaa230 5670
b5ec771e
PA
5671 Names prefixed with "standard__" are handled specially:
5672 "standard__" is first stripped off (by the lookup_name
5673 constructor), and only static and global symbols are searched.
14f9c5c9 5674
22cee43f
PMR
5675 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5676 to lookup global symbols. */
5677
5678static void
5679ada_add_all_symbols (struct obstack *obstackp,
5680 const struct block *block,
b5ec771e 5681 const lookup_name_info &lookup_name,
22cee43f
PMR
5682 domain_enum domain,
5683 int full_search,
5684 int *made_global_lookup_p)
14f9c5c9
AS
5685{
5686 struct symbol *sym;
14f9c5c9 5687
22cee43f
PMR
5688 if (made_global_lookup_p)
5689 *made_global_lookup_p = 0;
339c13b6
JB
5690
5691 /* Special case: If the user specifies a symbol name inside package
5692 Standard, do a non-wild matching of the symbol name without
5693 the "standard__" prefix. This was primarily introduced in order
5694 to allow the user to specifically access the standard exceptions
5695 using, for instance, Standard.Constraint_Error when Constraint_Error
5696 is ambiguous (due to the user defining its own Constraint_Error
5697 entity inside its program). */
b5ec771e
PA
5698 if (lookup_name.ada ().standard_p ())
5699 block = NULL;
4c4b4cd2 5700
339c13b6 5701 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5702
4eeaa230
DE
5703 if (block != NULL)
5704 {
5705 if (full_search)
b5ec771e 5706 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5707 else
5708 {
5709 /* In the !full_search case we're are being called by
5710 ada_iterate_over_symbols, and we don't want to search
5711 superblocks. */
b5ec771e 5712 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5713 }
22cee43f
PMR
5714 if (num_defns_collected (obstackp) > 0 || !full_search)
5715 return;
4eeaa230 5716 }
d2e4a39e 5717
339c13b6
JB
5718 /* No non-global symbols found. Check our cache to see if we have
5719 already performed this search before. If we have, then return
5720 the same result. */
5721
b5ec771e
PA
5722 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5723 domain, &sym, &block))
4c4b4cd2
PH
5724 {
5725 if (sym != NULL)
b5ec771e 5726 add_defn_to_vec (obstackp, sym, block);
22cee43f 5727 return;
4c4b4cd2 5728 }
14f9c5c9 5729
22cee43f
PMR
5730 if (made_global_lookup_p)
5731 *made_global_lookup_p = 1;
b1eedac9 5732
339c13b6
JB
5733 /* Search symbols from all global blocks. */
5734
b5ec771e 5735 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5736
4c4b4cd2 5737 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5738 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5739
22cee43f 5740 if (num_defns_collected (obstackp) == 0)
b5ec771e 5741 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5742}
5743
b5ec771e
PA
5744/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5745 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5746 matches.
54d343a2
TT
5747 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5748 found and the blocks and symbol tables (if any) in which they were
5749 found.
22cee43f
PMR
5750
5751 When full_search is non-zero, any non-function/non-enumeral
5752 symbol match within the nest of blocks whose innermost member is BLOCK,
5753 is the one match returned (no other matches in that or
5754 enclosing blocks is returned). If there are any matches in or
5755 surrounding BLOCK, then these alone are returned.
5756
5757 Names prefixed with "standard__" are handled specially: "standard__"
5758 is first stripped off, and only static and global symbols are searched. */
5759
5760static int
b5ec771e
PA
5761ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5762 const struct block *block,
22cee43f 5763 domain_enum domain,
54d343a2 5764 std::vector<struct block_symbol> *results,
22cee43f
PMR
5765 int full_search)
5766{
22cee43f
PMR
5767 int syms_from_global_search;
5768 int ndefns;
ec6a20c2 5769 auto_obstack obstack;
22cee43f 5770
ec6a20c2 5771 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5772 domain, full_search, &syms_from_global_search);
14f9c5c9 5773
ec6a20c2
JB
5774 ndefns = num_defns_collected (&obstack);
5775
54d343a2
TT
5776 struct block_symbol *base = defns_collected (&obstack, 1);
5777 for (int i = 0; i < ndefns; ++i)
5778 results->push_back (base[i]);
4c4b4cd2 5779
54d343a2 5780 ndefns = remove_extra_symbols (results);
4c4b4cd2 5781
b1eedac9 5782 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5783 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5784
b1eedac9 5785 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5786 cache_symbol (ada_lookup_name (lookup_name), domain,
5787 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5788
54d343a2 5789 ndefns = remove_irrelevant_renamings (results, block);
ec6a20c2 5790
14f9c5c9
AS
5791 return ndefns;
5792}
5793
b5ec771e 5794/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
54d343a2
TT
5795 in global scopes, returning the number of matches, and filling *RESULTS
5796 with (SYM,BLOCK) tuples.
ec6a20c2 5797
4eeaa230
DE
5798 See ada_lookup_symbol_list_worker for further details. */
5799
5800int
b5ec771e 5801ada_lookup_symbol_list (const char *name, const struct block *block,
54d343a2
TT
5802 domain_enum domain,
5803 std::vector<struct block_symbol> *results)
4eeaa230 5804{
b5ec771e
PA
5805 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5806 lookup_name_info lookup_name (name, name_match_type);
5807
5808 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5809}
5810
5811/* Implementation of the la_iterate_over_symbols method. */
5812
5813static void
14bc53a8 5814ada_iterate_over_symbols
b5ec771e
PA
5815 (const struct block *block, const lookup_name_info &name,
5816 domain_enum domain,
14bc53a8 5817 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5818{
5819 int ndefs, i;
54d343a2 5820 std::vector<struct block_symbol> results;
4eeaa230
DE
5821
5822 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2 5823
4eeaa230
DE
5824 for (i = 0; i < ndefs; ++i)
5825 {
7e41c8db 5826 if (!callback (&results[i]))
4eeaa230
DE
5827 break;
5828 }
5829}
5830
4e5c77fe
JB
5831/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5832 to 1, but choosing the first symbol found if there are multiple
5833 choices.
5834
5e2336be
JB
5835 The result is stored in *INFO, which must be non-NULL.
5836 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5837
5838void
5839ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5840 domain_enum domain,
d12307c1 5841 struct block_symbol *info)
14f9c5c9 5842{
b5ec771e
PA
5843 /* Since we already have an encoded name, wrap it in '<>' to force a
5844 verbatim match. Otherwise, if the name happens to not look like
5845 an encoded name (because it doesn't include a "__"),
5846 ada_lookup_name_info would re-encode/fold it again, and that
5847 would e.g., incorrectly lowercase object renaming names like
5848 "R28b" -> "r28b". */
5849 std::string verbatim = std::string ("<") + name + '>';
5850
5e2336be 5851 gdb_assert (info != NULL);
f98fc17b 5852 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5853}
aeb5907d
JB
5854
5855/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5856 scope and in global scopes, or NULL if none. NAME is folded and
5857 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5858 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5859 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5860
d12307c1 5861struct block_symbol
aeb5907d 5862ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5863 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5864{
5865 if (is_a_field_of_this != NULL)
5866 *is_a_field_of_this = 0;
5867
54d343a2 5868 std::vector<struct block_symbol> candidates;
f98fc17b 5869 int n_candidates;
f98fc17b
PA
5870
5871 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
f98fc17b
PA
5872
5873 if (n_candidates == 0)
54d343a2 5874 return {};
f98fc17b
PA
5875
5876 block_symbol info = candidates[0];
5877 info.symbol = fixup_symbol_section (info.symbol, NULL);
d12307c1 5878 return info;
4c4b4cd2 5879}
14f9c5c9 5880
d12307c1 5881static struct block_symbol
f606139a
DE
5882ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5883 const char *name,
76a01679 5884 const struct block *block,
21b556f4 5885 const domain_enum domain)
4c4b4cd2 5886{
d12307c1 5887 struct block_symbol sym;
04dccad0
JB
5888
5889 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5890 if (sym.symbol != NULL)
04dccad0
JB
5891 return sym;
5892
5893 /* If we haven't found a match at this point, try the primitive
5894 types. In other languages, this search is performed before
5895 searching for global symbols in order to short-circuit that
5896 global-symbol search if it happens that the name corresponds
5897 to a primitive type. But we cannot do the same in Ada, because
5898 it is perfectly legitimate for a program to declare a type which
5899 has the same name as a standard type. If looking up a type in
5900 that situation, we have traditionally ignored the primitive type
5901 in favor of user-defined types. This is why, unlike most other
5902 languages, we search the primitive types this late and only after
5903 having searched the global symbols without success. */
5904
5905 if (domain == VAR_DOMAIN)
5906 {
5907 struct gdbarch *gdbarch;
5908
5909 if (block == NULL)
5910 gdbarch = target_gdbarch ();
5911 else
5912 gdbarch = block_gdbarch (block);
d12307c1
PMR
5913 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5914 if (sym.symbol != NULL)
04dccad0
JB
5915 return sym;
5916 }
5917
d12307c1 5918 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5919}
5920
5921
4c4b4cd2
PH
5922/* True iff STR is a possible encoded suffix of a normal Ada name
5923 that is to be ignored for matching purposes. Suffixes of parallel
5924 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5925 are given by any of the regular expressions:
4c4b4cd2 5926
babe1480
JB
5927 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5928 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5929 TKB [subprogram suffix for task bodies]
babe1480 5930 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5931 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5932
5933 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5934 match is performed. This sequence is used to differentiate homonyms,
5935 is an optional part of a valid name suffix. */
4c4b4cd2 5936
14f9c5c9 5937static int
d2e4a39e 5938is_name_suffix (const char *str)
14f9c5c9
AS
5939{
5940 int k;
4c4b4cd2
PH
5941 const char *matching;
5942 const int len = strlen (str);
5943
babe1480
JB
5944 /* Skip optional leading __[0-9]+. */
5945
4c4b4cd2
PH
5946 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5947 {
babe1480
JB
5948 str += 3;
5949 while (isdigit (str[0]))
5950 str += 1;
4c4b4cd2 5951 }
babe1480
JB
5952
5953 /* [.$][0-9]+ */
4c4b4cd2 5954
babe1480 5955 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5956 {
babe1480 5957 matching = str + 1;
4c4b4cd2
PH
5958 while (isdigit (matching[0]))
5959 matching += 1;
5960 if (matching[0] == '\0')
5961 return 1;
5962 }
5963
5964 /* ___[0-9]+ */
babe1480 5965
4c4b4cd2
PH
5966 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5967 {
5968 matching = str + 3;
5969 while (isdigit (matching[0]))
5970 matching += 1;
5971 if (matching[0] == '\0')
5972 return 1;
5973 }
5974
9ac7f98e
JB
5975 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5976
5977 if (strcmp (str, "TKB") == 0)
5978 return 1;
5979
529cad9c
PH
5980#if 0
5981 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5982 with a N at the end. Unfortunately, the compiler uses the same
5983 convention for other internal types it creates. So treating
529cad9c 5984 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5985 some regressions. For instance, consider the case of an enumerated
5986 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5987 name ends with N.
5988 Having a single character like this as a suffix carrying some
0963b4bd 5989 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5990 to be something like "_N" instead. In the meantime, do not do
5991 the following check. */
5992 /* Protected Object Subprograms */
5993 if (len == 1 && str [0] == 'N')
5994 return 1;
5995#endif
5996
5997 /* _E[0-9]+[bs]$ */
5998 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5999 {
6000 matching = str + 3;
6001 while (isdigit (matching[0]))
6002 matching += 1;
6003 if ((matching[0] == 'b' || matching[0] == 's')
6004 && matching [1] == '\0')
6005 return 1;
6006 }
6007
4c4b4cd2
PH
6008 /* ??? We should not modify STR directly, as we are doing below. This
6009 is fine in this case, but may become problematic later if we find
6010 that this alternative did not work, and want to try matching
6011 another one from the begining of STR. Since we modified it, we
6012 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6013 if (str[0] == 'X')
6014 {
6015 str += 1;
d2e4a39e 6016 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6017 {
6018 if (str[0] != 'n' && str[0] != 'b')
6019 return 0;
6020 str += 1;
6021 }
14f9c5c9 6022 }
babe1480 6023
14f9c5c9
AS
6024 if (str[0] == '\000')
6025 return 1;
babe1480 6026
d2e4a39e 6027 if (str[0] == '_')
14f9c5c9
AS
6028 {
6029 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6030 return 0;
d2e4a39e 6031 if (str[2] == '_')
4c4b4cd2 6032 {
61ee279c
PH
6033 if (strcmp (str + 3, "JM") == 0)
6034 return 1;
6035 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6036 the LJM suffix in favor of the JM one. But we will
6037 still accept LJM as a valid suffix for a reasonable
6038 amount of time, just to allow ourselves to debug programs
6039 compiled using an older version of GNAT. */
4c4b4cd2
PH
6040 if (strcmp (str + 3, "LJM") == 0)
6041 return 1;
6042 if (str[3] != 'X')
6043 return 0;
1265e4aa
JB
6044 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6045 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6046 return 1;
6047 if (str[4] == 'R' && str[5] != 'T')
6048 return 1;
6049 return 0;
6050 }
6051 if (!isdigit (str[2]))
6052 return 0;
6053 for (k = 3; str[k] != '\0'; k += 1)
6054 if (!isdigit (str[k]) && str[k] != '_')
6055 return 0;
14f9c5c9
AS
6056 return 1;
6057 }
4c4b4cd2 6058 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6059 {
4c4b4cd2
PH
6060 for (k = 2; str[k] != '\0'; k += 1)
6061 if (!isdigit (str[k]) && str[k] != '_')
6062 return 0;
14f9c5c9
AS
6063 return 1;
6064 }
6065 return 0;
6066}
d2e4a39e 6067
aeb5907d
JB
6068/* Return non-zero if the string starting at NAME and ending before
6069 NAME_END contains no capital letters. */
529cad9c
PH
6070
6071static int
6072is_valid_name_for_wild_match (const char *name0)
6073{
6074 const char *decoded_name = ada_decode (name0);
6075 int i;
6076
5823c3ef
JB
6077 /* If the decoded name starts with an angle bracket, it means that
6078 NAME0 does not follow the GNAT encoding format. It should then
6079 not be allowed as a possible wild match. */
6080 if (decoded_name[0] == '<')
6081 return 0;
6082
529cad9c
PH
6083 for (i=0; decoded_name[i] != '\0'; i++)
6084 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6085 return 0;
6086
6087 return 1;
6088}
6089
73589123
PH
6090/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6091 that could start a simple name. Assumes that *NAMEP points into
6092 the string beginning at NAME0. */
4c4b4cd2 6093
14f9c5c9 6094static int
73589123 6095advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6096{
73589123 6097 const char *name = *namep;
5b4ee69b 6098
5823c3ef 6099 while (1)
14f9c5c9 6100 {
aa27d0b3 6101 int t0, t1;
73589123
PH
6102
6103 t0 = *name;
6104 if (t0 == '_')
6105 {
6106 t1 = name[1];
6107 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6108 {
6109 name += 1;
61012eef 6110 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6111 break;
6112 else
6113 name += 1;
6114 }
aa27d0b3
JB
6115 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6116 || name[2] == target0))
73589123
PH
6117 {
6118 name += 2;
6119 break;
6120 }
6121 else
6122 return 0;
6123 }
6124 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6125 name += 1;
6126 else
5823c3ef 6127 return 0;
73589123
PH
6128 }
6129
6130 *namep = name;
6131 return 1;
6132}
6133
b5ec771e
PA
6134/* Return true iff NAME encodes a name of the form prefix.PATN.
6135 Ignores any informational suffixes of NAME (i.e., for which
6136 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6137 simple name. */
73589123 6138
b5ec771e 6139static bool
73589123
PH
6140wild_match (const char *name, const char *patn)
6141{
22e048c9 6142 const char *p;
73589123
PH
6143 const char *name0 = name;
6144
6145 while (1)
6146 {
6147 const char *match = name;
6148
6149 if (*name == *patn)
6150 {
6151 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6152 if (*p != *name)
6153 break;
6154 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6155 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6156
6157 if (name[-1] == '_')
6158 name -= 1;
6159 }
6160 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6161 return false;
96d887e8 6162 }
96d887e8
PH
6163}
6164
b5ec771e
PA
6165/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6166 any trailing suffixes that encode debugging information or leading
6167 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6168 information that is ignored). */
40658b94 6169
b5ec771e 6170static bool
c4d840bd
PH
6171full_match (const char *sym_name, const char *search_name)
6172{
b5ec771e
PA
6173 size_t search_name_len = strlen (search_name);
6174
6175 if (strncmp (sym_name, search_name, search_name_len) == 0
6176 && is_name_suffix (sym_name + search_name_len))
6177 return true;
6178
6179 if (startswith (sym_name, "_ada_")
6180 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6181 && is_name_suffix (sym_name + search_name_len + 5))
6182 return true;
c4d840bd 6183
b5ec771e
PA
6184 return false;
6185}
c4d840bd 6186
b5ec771e
PA
6187/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6188 *defn_symbols, updating the list of symbols in OBSTACKP (if
6189 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6190
6191static void
6192ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6193 const struct block *block,
6194 const lookup_name_info &lookup_name,
6195 domain_enum domain, struct objfile *objfile)
96d887e8 6196{
8157b174 6197 struct block_iterator iter;
96d887e8
PH
6198 /* A matching argument symbol, if any. */
6199 struct symbol *arg_sym;
6200 /* Set true when we find a matching non-argument symbol. */
6201 int found_sym;
6202 struct symbol *sym;
6203
6204 arg_sym = NULL;
6205 found_sym = 0;
b5ec771e
PA
6206 for (sym = block_iter_match_first (block, lookup_name, &iter);
6207 sym != NULL;
6208 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6209 {
b5ec771e
PA
6210 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6211 SYMBOL_DOMAIN (sym), domain))
6212 {
6213 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6214 {
6215 if (SYMBOL_IS_ARGUMENT (sym))
6216 arg_sym = sym;
6217 else
6218 {
6219 found_sym = 1;
6220 add_defn_to_vec (obstackp,
6221 fixup_symbol_section (sym, objfile),
6222 block);
6223 }
6224 }
6225 }
96d887e8
PH
6226 }
6227
22cee43f
PMR
6228 /* Handle renamings. */
6229
b5ec771e 6230 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6231 found_sym = 1;
6232
96d887e8
PH
6233 if (!found_sym && arg_sym != NULL)
6234 {
76a01679
JB
6235 add_defn_to_vec (obstackp,
6236 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6237 block);
96d887e8
PH
6238 }
6239
b5ec771e 6240 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6241 {
6242 arg_sym = NULL;
6243 found_sym = 0;
b5ec771e
PA
6244 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6245 const char *name = ada_lookup_name.c_str ();
6246 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6247
6248 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6249 {
4186eb54
KS
6250 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6251 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6252 {
6253 int cmp;
6254
6255 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6256 if (cmp == 0)
6257 {
61012eef 6258 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6259 if (cmp == 0)
6260 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6261 name_len);
6262 }
6263
6264 if (cmp == 0
6265 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6266 {
2a2d4dc3
AS
6267 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6268 {
6269 if (SYMBOL_IS_ARGUMENT (sym))
6270 arg_sym = sym;
6271 else
6272 {
6273 found_sym = 1;
6274 add_defn_to_vec (obstackp,
6275 fixup_symbol_section (sym, objfile),
6276 block);
6277 }
6278 }
76a01679
JB
6279 }
6280 }
76a01679 6281 }
96d887e8
PH
6282
6283 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6284 They aren't parameters, right? */
6285 if (!found_sym && arg_sym != NULL)
6286 {
6287 add_defn_to_vec (obstackp,
76a01679 6288 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6289 block);
96d887e8
PH
6290 }
6291 }
6292}
6293\f
41d27058
JB
6294
6295 /* Symbol Completion */
6296
b5ec771e 6297/* See symtab.h. */
41d27058 6298
b5ec771e
PA
6299bool
6300ada_lookup_name_info::matches
6301 (const char *sym_name,
6302 symbol_name_match_type match_type,
a207cff2 6303 completion_match_result *comp_match_res) const
41d27058 6304{
b5ec771e
PA
6305 bool match = false;
6306 const char *text = m_encoded_name.c_str ();
6307 size_t text_len = m_encoded_name.size ();
41d27058
JB
6308
6309 /* First, test against the fully qualified name of the symbol. */
6310
6311 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6312 match = true;
41d27058 6313
b5ec771e 6314 if (match && !m_encoded_p)
41d27058
JB
6315 {
6316 /* One needed check before declaring a positive match is to verify
6317 that iff we are doing a verbatim match, the decoded version
6318 of the symbol name starts with '<'. Otherwise, this symbol name
6319 is not a suitable completion. */
6320 const char *sym_name_copy = sym_name;
b5ec771e 6321 bool has_angle_bracket;
41d27058
JB
6322
6323 sym_name = ada_decode (sym_name);
6324 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6325 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6326 sym_name = sym_name_copy;
6327 }
6328
b5ec771e 6329 if (match && !m_verbatim_p)
41d27058
JB
6330 {
6331 /* When doing non-verbatim match, another check that needs to
6332 be done is to verify that the potentially matching symbol name
6333 does not include capital letters, because the ada-mode would
6334 not be able to understand these symbol names without the
6335 angle bracket notation. */
6336 const char *tmp;
6337
6338 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6339 if (*tmp != '\0')
b5ec771e 6340 match = false;
41d27058
JB
6341 }
6342
6343 /* Second: Try wild matching... */
6344
b5ec771e 6345 if (!match && m_wild_match_p)
41d27058
JB
6346 {
6347 /* Since we are doing wild matching, this means that TEXT
6348 may represent an unqualified symbol name. We therefore must
6349 also compare TEXT against the unqualified name of the symbol. */
6350 sym_name = ada_unqualified_name (ada_decode (sym_name));
6351
6352 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6353 match = true;
41d27058
JB
6354 }
6355
b5ec771e 6356 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6357
6358 if (!match)
b5ec771e 6359 return false;
41d27058 6360
a207cff2 6361 if (comp_match_res != NULL)
b5ec771e 6362 {
a207cff2 6363 std::string &match_str = comp_match_res->match.storage ();
41d27058 6364
b5ec771e 6365 if (!m_encoded_p)
a207cff2 6366 match_str = ada_decode (sym_name);
b5ec771e
PA
6367 else
6368 {
6369 if (m_verbatim_p)
6370 match_str = add_angle_brackets (sym_name);
6371 else
6372 match_str = sym_name;
41d27058 6373
b5ec771e 6374 }
a207cff2
PA
6375
6376 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6377 }
6378
b5ec771e 6379 return true;
41d27058
JB
6380}
6381
b5ec771e 6382/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6383 WORD is the entire command on which completion is made. */
41d27058 6384
eb3ff9a5
PA
6385static void
6386ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6387 complete_symbol_mode mode,
b5ec771e
PA
6388 symbol_name_match_type name_match_type,
6389 const char *text, const char *word,
eb3ff9a5 6390 enum type_code code)
41d27058 6391{
41d27058 6392 struct symbol *sym;
3977b71f 6393 const struct block *b, *surrounding_static_block = 0;
8157b174 6394 struct block_iterator iter;
41d27058 6395
2f68a895
TT
6396 gdb_assert (code == TYPE_CODE_UNDEF);
6397
1b026119 6398 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6399
6400 /* First, look at the partial symtab symbols. */
14bc53a8 6401 expand_symtabs_matching (NULL,
b5ec771e
PA
6402 lookup_name,
6403 NULL,
14bc53a8
PA
6404 NULL,
6405 ALL_DOMAIN);
41d27058
JB
6406
6407 /* At this point scan through the misc symbol vectors and add each
6408 symbol you find to the list. Eventually we want to ignore
6409 anything that isn't a text symbol (everything else will be
6410 handled by the psymtab code above). */
6411
2030c079 6412 for (objfile *objfile : current_program_space->objfiles ())
5325b9bf
TT
6413 {
6414 for (minimal_symbol *msymbol : objfile_msymbols (objfile))
6415 {
6416 QUIT;
6417
6418 if (completion_skip_symbol (mode, msymbol))
6419 continue;
6420
6421 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6422
6423 /* Ada minimal symbols won't have their language set to Ada. If
6424 we let completion_list_add_name compare using the
6425 default/C-like matcher, then when completing e.g., symbols in a
6426 package named "pck", we'd match internal Ada symbols like
6427 "pckS", which are invalid in an Ada expression, unless you wrap
6428 them in '<' '>' to request a verbatim match.
6429
6430 Unfortunately, some Ada encoded names successfully demangle as
6431 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6432 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6433 with the wrong language set. Paper over that issue here. */
6434 if (symbol_language == language_auto
6435 || symbol_language == language_cplus)
6436 symbol_language = language_ada;
6437
6438 completion_list_add_name (tracker,
6439 symbol_language,
6440 MSYMBOL_LINKAGE_NAME (msymbol),
6441 lookup_name, text, word);
6442 }
6443 }
41d27058
JB
6444
6445 /* Search upwards from currently selected frame (so that we can
6446 complete on local vars. */
6447
6448 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6449 {
6450 if (!BLOCK_SUPERBLOCK (b))
6451 surrounding_static_block = b; /* For elmin of dups */
6452
6453 ALL_BLOCK_SYMBOLS (b, iter, sym)
6454 {
f9d67a22
PA
6455 if (completion_skip_symbol (mode, sym))
6456 continue;
6457
b5ec771e
PA
6458 completion_list_add_name (tracker,
6459 SYMBOL_LANGUAGE (sym),
6460 SYMBOL_LINKAGE_NAME (sym),
1b026119 6461 lookup_name, text, word);
41d27058
JB
6462 }
6463 }
6464
6465 /* Go through the symtabs and check the externs and statics for
43f3e411 6466 symbols which match. */
41d27058 6467
2030c079 6468 for (objfile *objfile : current_program_space->objfiles ())
41d27058 6469 {
d8aeb77f
TT
6470 for (compunit_symtab *s : objfile_compunits (objfile))
6471 {
6472 QUIT;
6473 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6474 ALL_BLOCK_SYMBOLS (b, iter, sym)
6475 {
6476 if (completion_skip_symbol (mode, sym))
6477 continue;
f9d67a22 6478
d8aeb77f
TT
6479 completion_list_add_name (tracker,
6480 SYMBOL_LANGUAGE (sym),
6481 SYMBOL_LINKAGE_NAME (sym),
6482 lookup_name, text, word);
6483 }
6484 }
41d27058 6485 }
41d27058 6486
2030c079 6487 for (objfile *objfile : current_program_space->objfiles ())
d8aeb77f
TT
6488 {
6489 for (compunit_symtab *s : objfile_compunits (objfile))
6490 {
6491 QUIT;
6492 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6493 /* Don't do this block twice. */
6494 if (b == surrounding_static_block)
6495 continue;
6496 ALL_BLOCK_SYMBOLS (b, iter, sym)
6497 {
6498 if (completion_skip_symbol (mode, sym))
6499 continue;
f9d67a22 6500
d8aeb77f
TT
6501 completion_list_add_name (tracker,
6502 SYMBOL_LANGUAGE (sym),
6503 SYMBOL_LINKAGE_NAME (sym),
6504 lookup_name, text, word);
6505 }
6506 }
41d27058 6507 }
41d27058
JB
6508}
6509
963a6417 6510 /* Field Access */
96d887e8 6511
73fb9985
JB
6512/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6513 for tagged types. */
6514
6515static int
6516ada_is_dispatch_table_ptr_type (struct type *type)
6517{
0d5cff50 6518 const char *name;
73fb9985
JB
6519
6520 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6521 return 0;
6522
6523 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6524 if (name == NULL)
6525 return 0;
6526
6527 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6528}
6529
ac4a2da4
JG
6530/* Return non-zero if TYPE is an interface tag. */
6531
6532static int
6533ada_is_interface_tag (struct type *type)
6534{
6535 const char *name = TYPE_NAME (type);
6536
6537 if (name == NULL)
6538 return 0;
6539
6540 return (strcmp (name, "ada__tags__interface_tag") == 0);
6541}
6542
963a6417
PH
6543/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6544 to be invisible to users. */
96d887e8 6545
963a6417
PH
6546int
6547ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6548{
963a6417
PH
6549 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6550 return 1;
ffde82bf 6551
73fb9985
JB
6552 /* Check the name of that field. */
6553 {
6554 const char *name = TYPE_FIELD_NAME (type, field_num);
6555
6556 /* Anonymous field names should not be printed.
6557 brobecker/2007-02-20: I don't think this can actually happen
6558 but we don't want to print the value of annonymous fields anyway. */
6559 if (name == NULL)
6560 return 1;
6561
ffde82bf
JB
6562 /* Normally, fields whose name start with an underscore ("_")
6563 are fields that have been internally generated by the compiler,
6564 and thus should not be printed. The "_parent" field is special,
6565 however: This is a field internally generated by the compiler
6566 for tagged types, and it contains the components inherited from
6567 the parent type. This field should not be printed as is, but
6568 should not be ignored either. */
61012eef 6569 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6570 return 1;
6571 }
6572
ac4a2da4
JG
6573 /* If this is the dispatch table of a tagged type or an interface tag,
6574 then ignore. */
73fb9985 6575 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6576 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6577 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6578 return 1;
6579
6580 /* Not a special field, so it should not be ignored. */
6581 return 0;
963a6417 6582}
96d887e8 6583
963a6417 6584/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6585 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6586
963a6417
PH
6587int
6588ada_is_tagged_type (struct type *type, int refok)
6589{
988f6b3d 6590 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6591}
96d887e8 6592
963a6417 6593/* True iff TYPE represents the type of X'Tag */
96d887e8 6594
963a6417
PH
6595int
6596ada_is_tag_type (struct type *type)
6597{
460efde1
JB
6598 type = ada_check_typedef (type);
6599
963a6417
PH
6600 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6601 return 0;
6602 else
96d887e8 6603 {
963a6417 6604 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6605
963a6417
PH
6606 return (name != NULL
6607 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6608 }
96d887e8
PH
6609}
6610
963a6417 6611/* The type of the tag on VAL. */
76a01679 6612
963a6417
PH
6613struct type *
6614ada_tag_type (struct value *val)
96d887e8 6615{
988f6b3d 6616 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6617}
96d887e8 6618
b50d69b5
JG
6619/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6620 retired at Ada 05). */
6621
6622static int
6623is_ada95_tag (struct value *tag)
6624{
6625 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6626}
6627
963a6417 6628/* The value of the tag on VAL. */
96d887e8 6629
963a6417
PH
6630struct value *
6631ada_value_tag (struct value *val)
6632{
03ee6b2e 6633 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6634}
6635
963a6417
PH
6636/* The value of the tag on the object of type TYPE whose contents are
6637 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6638 ADDRESS. */
96d887e8 6639
963a6417 6640static struct value *
10a2c479 6641value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6642 const gdb_byte *valaddr,
963a6417 6643 CORE_ADDR address)
96d887e8 6644{
b5385fc0 6645 int tag_byte_offset;
963a6417 6646 struct type *tag_type;
5b4ee69b 6647
963a6417 6648 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6649 NULL, NULL, NULL))
96d887e8 6650 {
fc1a4b47 6651 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6652 ? NULL
6653 : valaddr + tag_byte_offset);
963a6417 6654 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6655
963a6417 6656 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6657 }
963a6417
PH
6658 return NULL;
6659}
96d887e8 6660
963a6417
PH
6661static struct type *
6662type_from_tag (struct value *tag)
6663{
6664 const char *type_name = ada_tag_name (tag);
5b4ee69b 6665
963a6417
PH
6666 if (type_name != NULL)
6667 return ada_find_any_type (ada_encode (type_name));
6668 return NULL;
6669}
96d887e8 6670
b50d69b5
JG
6671/* Given a value OBJ of a tagged type, return a value of this
6672 type at the base address of the object. The base address, as
6673 defined in Ada.Tags, it is the address of the primary tag of
6674 the object, and therefore where the field values of its full
6675 view can be fetched. */
6676
6677struct value *
6678ada_tag_value_at_base_address (struct value *obj)
6679{
b50d69b5
JG
6680 struct value *val;
6681 LONGEST offset_to_top = 0;
6682 struct type *ptr_type, *obj_type;
6683 struct value *tag;
6684 CORE_ADDR base_address;
6685
6686 obj_type = value_type (obj);
6687
6688 /* It is the responsability of the caller to deref pointers. */
6689
6690 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6691 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6692 return obj;
6693
6694 tag = ada_value_tag (obj);
6695 if (!tag)
6696 return obj;
6697
6698 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6699
6700 if (is_ada95_tag (tag))
6701 return obj;
6702
08f49010
XR
6703 ptr_type = language_lookup_primitive_type
6704 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6705 ptr_type = lookup_pointer_type (ptr_type);
6706 val = value_cast (ptr_type, tag);
6707 if (!val)
6708 return obj;
6709
6710 /* It is perfectly possible that an exception be raised while
6711 trying to determine the base address, just like for the tag;
6712 see ada_tag_name for more details. We do not print the error
6713 message for the same reason. */
6714
492d29ea 6715 TRY
b50d69b5
JG
6716 {
6717 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6718 }
6719
492d29ea
PA
6720 CATCH (e, RETURN_MASK_ERROR)
6721 {
6722 return obj;
6723 }
6724 END_CATCH
b50d69b5
JG
6725
6726 /* If offset is null, nothing to do. */
6727
6728 if (offset_to_top == 0)
6729 return obj;
6730
6731 /* -1 is a special case in Ada.Tags; however, what should be done
6732 is not quite clear from the documentation. So do nothing for
6733 now. */
6734
6735 if (offset_to_top == -1)
6736 return obj;
6737
08f49010
XR
6738 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6739 from the base address. This was however incompatible with
6740 C++ dispatch table: C++ uses a *negative* value to *add*
6741 to the base address. Ada's convention has therefore been
6742 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6743 use the same convention. Here, we support both cases by
6744 checking the sign of OFFSET_TO_TOP. */
6745
6746 if (offset_to_top > 0)
6747 offset_to_top = -offset_to_top;
6748
6749 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6750 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6751
6752 /* Make sure that we have a proper tag at the new address.
6753 Otherwise, offset_to_top is bogus (which can happen when
6754 the object is not initialized yet). */
6755
6756 if (!tag)
6757 return obj;
6758
6759 obj_type = type_from_tag (tag);
6760
6761 if (!obj_type)
6762 return obj;
6763
6764 return value_from_contents_and_address (obj_type, NULL, base_address);
6765}
6766
1b611343
JB
6767/* Return the "ada__tags__type_specific_data" type. */
6768
6769static struct type *
6770ada_get_tsd_type (struct inferior *inf)
963a6417 6771{
1b611343 6772 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6773
1b611343
JB
6774 if (data->tsd_type == 0)
6775 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6776 return data->tsd_type;
6777}
529cad9c 6778
1b611343
JB
6779/* Return the TSD (type-specific data) associated to the given TAG.
6780 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6781
1b611343 6782 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6783
1b611343
JB
6784static struct value *
6785ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6786{
4c4b4cd2 6787 struct value *val;
1b611343 6788 struct type *type;
5b4ee69b 6789
1b611343
JB
6790 /* First option: The TSD is simply stored as a field of our TAG.
6791 Only older versions of GNAT would use this format, but we have
6792 to test it first, because there are no visible markers for
6793 the current approach except the absence of that field. */
529cad9c 6794
1b611343
JB
6795 val = ada_value_struct_elt (tag, "tsd", 1);
6796 if (val)
6797 return val;
e802dbe0 6798
1b611343
JB
6799 /* Try the second representation for the dispatch table (in which
6800 there is no explicit 'tsd' field in the referent of the tag pointer,
6801 and instead the tsd pointer is stored just before the dispatch
6802 table. */
e802dbe0 6803
1b611343
JB
6804 type = ada_get_tsd_type (current_inferior());
6805 if (type == NULL)
6806 return NULL;
6807 type = lookup_pointer_type (lookup_pointer_type (type));
6808 val = value_cast (type, tag);
6809 if (val == NULL)
6810 return NULL;
6811 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6812}
6813
1b611343
JB
6814/* Given the TSD of a tag (type-specific data), return a string
6815 containing the name of the associated type.
6816
6817 The returned value is good until the next call. May return NULL
6818 if we are unable to determine the tag name. */
6819
6820static char *
6821ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6822{
529cad9c
PH
6823 static char name[1024];
6824 char *p;
1b611343 6825 struct value *val;
529cad9c 6826
1b611343 6827 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6828 if (val == NULL)
1b611343 6829 return NULL;
4c4b4cd2
PH
6830 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6831 for (p = name; *p != '\0'; p += 1)
6832 if (isalpha (*p))
6833 *p = tolower (*p);
1b611343 6834 return name;
4c4b4cd2
PH
6835}
6836
6837/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6838 a C string.
6839
6840 Return NULL if the TAG is not an Ada tag, or if we were unable to
6841 determine the name of that tag. The result is good until the next
6842 call. */
4c4b4cd2
PH
6843
6844const char *
6845ada_tag_name (struct value *tag)
6846{
1b611343 6847 char *name = NULL;
5b4ee69b 6848
df407dfe 6849 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6850 return NULL;
1b611343
JB
6851
6852 /* It is perfectly possible that an exception be raised while trying
6853 to determine the TAG's name, even under normal circumstances:
6854 The associated variable may be uninitialized or corrupted, for
6855 instance. We do not let any exception propagate past this point.
6856 instead we return NULL.
6857
6858 We also do not print the error message either (which often is very
6859 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6860 the caller print a more meaningful message if necessary. */
492d29ea 6861 TRY
1b611343
JB
6862 {
6863 struct value *tsd = ada_get_tsd_from_tag (tag);
6864
6865 if (tsd != NULL)
6866 name = ada_tag_name_from_tsd (tsd);
6867 }
492d29ea
PA
6868 CATCH (e, RETURN_MASK_ERROR)
6869 {
6870 }
6871 END_CATCH
1b611343
JB
6872
6873 return name;
4c4b4cd2
PH
6874}
6875
6876/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6877
d2e4a39e 6878struct type *
ebf56fd3 6879ada_parent_type (struct type *type)
14f9c5c9
AS
6880{
6881 int i;
6882
61ee279c 6883 type = ada_check_typedef (type);
14f9c5c9
AS
6884
6885 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6886 return NULL;
6887
6888 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6889 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6890 {
6891 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6892
6893 /* If the _parent field is a pointer, then dereference it. */
6894 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6895 parent_type = TYPE_TARGET_TYPE (parent_type);
6896 /* If there is a parallel XVS type, get the actual base type. */
6897 parent_type = ada_get_base_type (parent_type);
6898
6899 return ada_check_typedef (parent_type);
6900 }
14f9c5c9
AS
6901
6902 return NULL;
6903}
6904
4c4b4cd2
PH
6905/* True iff field number FIELD_NUM of structure type TYPE contains the
6906 parent-type (inherited) fields of a derived type. Assumes TYPE is
6907 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6908
6909int
ebf56fd3 6910ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6911{
61ee279c 6912 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6913
4c4b4cd2 6914 return (name != NULL
61012eef
GB
6915 && (startswith (name, "PARENT")
6916 || startswith (name, "_parent")));
14f9c5c9
AS
6917}
6918
4c4b4cd2 6919/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6920 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6921 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6922 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6923 structures. */
14f9c5c9
AS
6924
6925int
ebf56fd3 6926ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6927{
d2e4a39e 6928 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6929
dddc0e16
JB
6930 if (name != NULL && strcmp (name, "RETVAL") == 0)
6931 {
6932 /* This happens in functions with "out" or "in out" parameters
6933 which are passed by copy. For such functions, GNAT describes
6934 the function's return type as being a struct where the return
6935 value is in a field called RETVAL, and where the other "out"
6936 or "in out" parameters are fields of that struct. This is not
6937 a wrapper. */
6938 return 0;
6939 }
6940
d2e4a39e 6941 return (name != NULL
61012eef 6942 && (startswith (name, "PARENT")
4c4b4cd2 6943 || strcmp (name, "REP") == 0
61012eef 6944 || startswith (name, "_parent")
4c4b4cd2 6945 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6946}
6947
4c4b4cd2
PH
6948/* True iff field number FIELD_NUM of structure or union type TYPE
6949 is a variant wrapper. Assumes TYPE is a structure type with at least
6950 FIELD_NUM+1 fields. */
14f9c5c9
AS
6951
6952int
ebf56fd3 6953ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6954{
d2e4a39e 6955 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6956
14f9c5c9 6957 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6958 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6959 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6960 == TYPE_CODE_UNION)));
14f9c5c9
AS
6961}
6962
6963/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6964 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6965 returns the type of the controlling discriminant for the variant.
6966 May return NULL if the type could not be found. */
14f9c5c9 6967
d2e4a39e 6968struct type *
ebf56fd3 6969ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6970{
a121b7c1 6971 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6972
988f6b3d 6973 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
6974}
6975
4c4b4cd2 6976/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6977 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6978 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6979
6980int
ebf56fd3 6981ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6982{
d2e4a39e 6983 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6984
14f9c5c9
AS
6985 return (name != NULL && name[0] == 'O');
6986}
6987
6988/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6989 returns the name of the discriminant controlling the variant.
6990 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6991
a121b7c1 6992const char *
ebf56fd3 6993ada_variant_discrim_name (struct type *type0)
14f9c5c9 6994{
d2e4a39e 6995 static char *result = NULL;
14f9c5c9 6996 static size_t result_len = 0;
d2e4a39e
AS
6997 struct type *type;
6998 const char *name;
6999 const char *discrim_end;
7000 const char *discrim_start;
14f9c5c9
AS
7001
7002 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7003 type = TYPE_TARGET_TYPE (type0);
7004 else
7005 type = type0;
7006
7007 name = ada_type_name (type);
7008
7009 if (name == NULL || name[0] == '\000')
7010 return "";
7011
7012 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7013 discrim_end -= 1)
7014 {
61012eef 7015 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7016 break;
14f9c5c9
AS
7017 }
7018 if (discrim_end == name)
7019 return "";
7020
d2e4a39e 7021 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7022 discrim_start -= 1)
7023 {
d2e4a39e 7024 if (discrim_start == name + 1)
4c4b4cd2 7025 return "";
76a01679 7026 if ((discrim_start > name + 3
61012eef 7027 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7028 || discrim_start[-1] == '.')
7029 break;
14f9c5c9
AS
7030 }
7031
7032 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7033 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7034 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7035 return result;
7036}
7037
4c4b4cd2
PH
7038/* Scan STR for a subtype-encoded number, beginning at position K.
7039 Put the position of the character just past the number scanned in
7040 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7041 Return 1 if there was a valid number at the given position, and 0
7042 otherwise. A "subtype-encoded" number consists of the absolute value
7043 in decimal, followed by the letter 'm' to indicate a negative number.
7044 Assumes 0m does not occur. */
14f9c5c9
AS
7045
7046int
d2e4a39e 7047ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7048{
7049 ULONGEST RU;
7050
d2e4a39e 7051 if (!isdigit (str[k]))
14f9c5c9
AS
7052 return 0;
7053
4c4b4cd2 7054 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7055 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7056 LONGEST. */
14f9c5c9
AS
7057 RU = 0;
7058 while (isdigit (str[k]))
7059 {
d2e4a39e 7060 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7061 k += 1;
7062 }
7063
d2e4a39e 7064 if (str[k] == 'm')
14f9c5c9
AS
7065 {
7066 if (R != NULL)
4c4b4cd2 7067 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7068 k += 1;
7069 }
7070 else if (R != NULL)
7071 *R = (LONGEST) RU;
7072
4c4b4cd2 7073 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7074 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7075 number representable as a LONGEST (although either would probably work
7076 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7077 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7078
7079 if (new_k != NULL)
7080 *new_k = k;
7081 return 1;
7082}
7083
4c4b4cd2
PH
7084/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7085 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7086 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7087
d2e4a39e 7088int
ebf56fd3 7089ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7090{
d2e4a39e 7091 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7092 int p;
7093
7094 p = 0;
7095 while (1)
7096 {
d2e4a39e 7097 switch (name[p])
4c4b4cd2
PH
7098 {
7099 case '\0':
7100 return 0;
7101 case 'S':
7102 {
7103 LONGEST W;
5b4ee69b 7104
4c4b4cd2
PH
7105 if (!ada_scan_number (name, p + 1, &W, &p))
7106 return 0;
7107 if (val == W)
7108 return 1;
7109 break;
7110 }
7111 case 'R':
7112 {
7113 LONGEST L, U;
5b4ee69b 7114
4c4b4cd2
PH
7115 if (!ada_scan_number (name, p + 1, &L, &p)
7116 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7117 return 0;
7118 if (val >= L && val <= U)
7119 return 1;
7120 break;
7121 }
7122 case 'O':
7123 return 1;
7124 default:
7125 return 0;
7126 }
7127 }
7128}
7129
0963b4bd 7130/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7131
7132/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7133 ARG_TYPE, extract and return the value of one of its (non-static)
7134 fields. FIELDNO says which field. Differs from value_primitive_field
7135 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7136
4c4b4cd2 7137static struct value *
d2e4a39e 7138ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7139 struct type *arg_type)
14f9c5c9 7140{
14f9c5c9
AS
7141 struct type *type;
7142
61ee279c 7143 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7144 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7145
4c4b4cd2 7146 /* Handle packed fields. */
14f9c5c9
AS
7147
7148 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7149 {
7150 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7151 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7152
0fd88904 7153 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7154 offset + bit_pos / 8,
7155 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7156 }
7157 else
7158 return value_primitive_field (arg1, offset, fieldno, arg_type);
7159}
7160
52ce6436
PH
7161/* Find field with name NAME in object of type TYPE. If found,
7162 set the following for each argument that is non-null:
7163 - *FIELD_TYPE_P to the field's type;
7164 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7165 an object of that type;
7166 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7167 - *BIT_SIZE_P to its size in bits if the field is packed, and
7168 0 otherwise;
7169 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7170 fields up to but not including the desired field, or by the total
7171 number of fields if not found. A NULL value of NAME never
7172 matches; the function just counts visible fields in this case.
7173
828d5846
XR
7174 Notice that we need to handle when a tagged record hierarchy
7175 has some components with the same name, like in this scenario:
7176
7177 type Top_T is tagged record
7178 N : Integer := 1;
7179 U : Integer := 974;
7180 A : Integer := 48;
7181 end record;
7182
7183 type Middle_T is new Top.Top_T with record
7184 N : Character := 'a';
7185 C : Integer := 3;
7186 end record;
7187
7188 type Bottom_T is new Middle.Middle_T with record
7189 N : Float := 4.0;
7190 C : Character := '5';
7191 X : Integer := 6;
7192 A : Character := 'J';
7193 end record;
7194
7195 Let's say we now have a variable declared and initialized as follow:
7196
7197 TC : Top_A := new Bottom_T;
7198
7199 And then we use this variable to call this function
7200
7201 procedure Assign (Obj: in out Top_T; TV : Integer);
7202
7203 as follow:
7204
7205 Assign (Top_T (B), 12);
7206
7207 Now, we're in the debugger, and we're inside that procedure
7208 then and we want to print the value of obj.c:
7209
7210 Usually, the tagged record or one of the parent type owns the
7211 component to print and there's no issue but in this particular
7212 case, what does it mean to ask for Obj.C? Since the actual
7213 type for object is type Bottom_T, it could mean two things: type
7214 component C from the Middle_T view, but also component C from
7215 Bottom_T. So in that "undefined" case, when the component is
7216 not found in the non-resolved type (which includes all the
7217 components of the parent type), then resolve it and see if we
7218 get better luck once expanded.
7219
7220 In the case of homonyms in the derived tagged type, we don't
7221 guaranty anything, and pick the one that's easiest for us
7222 to program.
7223
0963b4bd 7224 Returns 1 if found, 0 otherwise. */
52ce6436 7225
4c4b4cd2 7226static int
0d5cff50 7227find_struct_field (const char *name, struct type *type, int offset,
76a01679 7228 struct type **field_type_p,
52ce6436
PH
7229 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7230 int *index_p)
4c4b4cd2
PH
7231{
7232 int i;
828d5846 7233 int parent_offset = -1;
4c4b4cd2 7234
61ee279c 7235 type = ada_check_typedef (type);
76a01679 7236
52ce6436
PH
7237 if (field_type_p != NULL)
7238 *field_type_p = NULL;
7239 if (byte_offset_p != NULL)
d5d6fca5 7240 *byte_offset_p = 0;
52ce6436
PH
7241 if (bit_offset_p != NULL)
7242 *bit_offset_p = 0;
7243 if (bit_size_p != NULL)
7244 *bit_size_p = 0;
7245
7246 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7247 {
7248 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7249 int fld_offset = offset + bit_pos / 8;
0d5cff50 7250 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7251
4c4b4cd2
PH
7252 if (t_field_name == NULL)
7253 continue;
7254
828d5846
XR
7255 else if (ada_is_parent_field (type, i))
7256 {
7257 /* This is a field pointing us to the parent type of a tagged
7258 type. As hinted in this function's documentation, we give
7259 preference to fields in the current record first, so what
7260 we do here is just record the index of this field before
7261 we skip it. If it turns out we couldn't find our field
7262 in the current record, then we'll get back to it and search
7263 inside it whether the field might exist in the parent. */
7264
7265 parent_offset = i;
7266 continue;
7267 }
7268
52ce6436 7269 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7270 {
7271 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7272
52ce6436
PH
7273 if (field_type_p != NULL)
7274 *field_type_p = TYPE_FIELD_TYPE (type, i);
7275 if (byte_offset_p != NULL)
7276 *byte_offset_p = fld_offset;
7277 if (bit_offset_p != NULL)
7278 *bit_offset_p = bit_pos % 8;
7279 if (bit_size_p != NULL)
7280 *bit_size_p = bit_size;
76a01679
JB
7281 return 1;
7282 }
4c4b4cd2
PH
7283 else if (ada_is_wrapper_field (type, i))
7284 {
52ce6436
PH
7285 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7286 field_type_p, byte_offset_p, bit_offset_p,
7287 bit_size_p, index_p))
76a01679
JB
7288 return 1;
7289 }
4c4b4cd2
PH
7290 else if (ada_is_variant_part (type, i))
7291 {
52ce6436
PH
7292 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7293 fixed type?? */
4c4b4cd2 7294 int j;
52ce6436
PH
7295 struct type *field_type
7296 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7297
52ce6436 7298 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7299 {
76a01679
JB
7300 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7301 fld_offset
7302 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7303 field_type_p, byte_offset_p,
52ce6436 7304 bit_offset_p, bit_size_p, index_p))
76a01679 7305 return 1;
4c4b4cd2
PH
7306 }
7307 }
52ce6436
PH
7308 else if (index_p != NULL)
7309 *index_p += 1;
4c4b4cd2 7310 }
828d5846
XR
7311
7312 /* Field not found so far. If this is a tagged type which
7313 has a parent, try finding that field in the parent now. */
7314
7315 if (parent_offset != -1)
7316 {
7317 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7318 int fld_offset = offset + bit_pos / 8;
7319
7320 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7321 fld_offset, field_type_p, byte_offset_p,
7322 bit_offset_p, bit_size_p, index_p))
7323 return 1;
7324 }
7325
4c4b4cd2
PH
7326 return 0;
7327}
7328
0963b4bd 7329/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7330
52ce6436
PH
7331static int
7332num_visible_fields (struct type *type)
7333{
7334 int n;
5b4ee69b 7335
52ce6436
PH
7336 n = 0;
7337 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7338 return n;
7339}
14f9c5c9 7340
4c4b4cd2 7341/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7342 and search in it assuming it has (class) type TYPE.
7343 If found, return value, else return NULL.
7344
828d5846
XR
7345 Searches recursively through wrapper fields (e.g., '_parent').
7346
7347 In the case of homonyms in the tagged types, please refer to the
7348 long explanation in find_struct_field's function documentation. */
14f9c5c9 7349
4c4b4cd2 7350static struct value *
108d56a4 7351ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7352 struct type *type)
14f9c5c9
AS
7353{
7354 int i;
828d5846 7355 int parent_offset = -1;
14f9c5c9 7356
5b4ee69b 7357 type = ada_check_typedef (type);
52ce6436 7358 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7359 {
0d5cff50 7360 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7361
7362 if (t_field_name == NULL)
4c4b4cd2 7363 continue;
14f9c5c9 7364
828d5846
XR
7365 else if (ada_is_parent_field (type, i))
7366 {
7367 /* This is a field pointing us to the parent type of a tagged
7368 type. As hinted in this function's documentation, we give
7369 preference to fields in the current record first, so what
7370 we do here is just record the index of this field before
7371 we skip it. If it turns out we couldn't find our field
7372 in the current record, then we'll get back to it and search
7373 inside it whether the field might exist in the parent. */
7374
7375 parent_offset = i;
7376 continue;
7377 }
7378
14f9c5c9 7379 else if (field_name_match (t_field_name, name))
4c4b4cd2 7380 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7381
7382 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7383 {
0963b4bd 7384 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7385 ada_search_struct_field (name, arg,
7386 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7387 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7388
4c4b4cd2
PH
7389 if (v != NULL)
7390 return v;
7391 }
14f9c5c9
AS
7392
7393 else if (ada_is_variant_part (type, i))
4c4b4cd2 7394 {
0963b4bd 7395 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7396 int j;
5b4ee69b
MS
7397 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7398 i));
4c4b4cd2
PH
7399 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7400
52ce6436 7401 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7402 {
0963b4bd
MS
7403 struct value *v = ada_search_struct_field /* Force line
7404 break. */
06d5cf63
JB
7405 (name, arg,
7406 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7407 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7408
4c4b4cd2
PH
7409 if (v != NULL)
7410 return v;
7411 }
7412 }
14f9c5c9 7413 }
828d5846
XR
7414
7415 /* Field not found so far. If this is a tagged type which
7416 has a parent, try finding that field in the parent now. */
7417
7418 if (parent_offset != -1)
7419 {
7420 struct value *v = ada_search_struct_field (
7421 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7422 TYPE_FIELD_TYPE (type, parent_offset));
7423
7424 if (v != NULL)
7425 return v;
7426 }
7427
14f9c5c9
AS
7428 return NULL;
7429}
d2e4a39e 7430
52ce6436
PH
7431static struct value *ada_index_struct_field_1 (int *, struct value *,
7432 int, struct type *);
7433
7434
7435/* Return field #INDEX in ARG, where the index is that returned by
7436 * find_struct_field through its INDEX_P argument. Adjust the address
7437 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7438 * If found, return value, else return NULL. */
52ce6436
PH
7439
7440static struct value *
7441ada_index_struct_field (int index, struct value *arg, int offset,
7442 struct type *type)
7443{
7444 return ada_index_struct_field_1 (&index, arg, offset, type);
7445}
7446
7447
7448/* Auxiliary function for ada_index_struct_field. Like
7449 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7450 * *INDEX_P. */
52ce6436
PH
7451
7452static struct value *
7453ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7454 struct type *type)
7455{
7456 int i;
7457 type = ada_check_typedef (type);
7458
7459 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7460 {
7461 if (TYPE_FIELD_NAME (type, i) == NULL)
7462 continue;
7463 else if (ada_is_wrapper_field (type, i))
7464 {
0963b4bd 7465 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7466 ada_index_struct_field_1 (index_p, arg,
7467 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7468 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7469
52ce6436
PH
7470 if (v != NULL)
7471 return v;
7472 }
7473
7474 else if (ada_is_variant_part (type, i))
7475 {
7476 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7477 find_struct_field. */
52ce6436
PH
7478 error (_("Cannot assign this kind of variant record"));
7479 }
7480 else if (*index_p == 0)
7481 return ada_value_primitive_field (arg, offset, i, type);
7482 else
7483 *index_p -= 1;
7484 }
7485 return NULL;
7486}
7487
4c4b4cd2
PH
7488/* Given ARG, a value of type (pointer or reference to a)*
7489 structure/union, extract the component named NAME from the ultimate
7490 target structure/union and return it as a value with its
f5938064 7491 appropriate type.
14f9c5c9 7492
4c4b4cd2
PH
7493 The routine searches for NAME among all members of the structure itself
7494 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7495 (e.g., '_parent').
7496
03ee6b2e
PH
7497 If NO_ERR, then simply return NULL in case of error, rather than
7498 calling error. */
14f9c5c9 7499
d2e4a39e 7500struct value *
a121b7c1 7501ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7502{
4c4b4cd2 7503 struct type *t, *t1;
d2e4a39e 7504 struct value *v;
1f5d1570 7505 int check_tag;
14f9c5c9 7506
4c4b4cd2 7507 v = NULL;
df407dfe 7508 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7509 if (TYPE_CODE (t) == TYPE_CODE_REF)
7510 {
7511 t1 = TYPE_TARGET_TYPE (t);
7512 if (t1 == NULL)
03ee6b2e 7513 goto BadValue;
61ee279c 7514 t1 = ada_check_typedef (t1);
4c4b4cd2 7515 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7516 {
994b9211 7517 arg = coerce_ref (arg);
76a01679
JB
7518 t = t1;
7519 }
4c4b4cd2 7520 }
14f9c5c9 7521
4c4b4cd2
PH
7522 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7523 {
7524 t1 = TYPE_TARGET_TYPE (t);
7525 if (t1 == NULL)
03ee6b2e 7526 goto BadValue;
61ee279c 7527 t1 = ada_check_typedef (t1);
4c4b4cd2 7528 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7529 {
7530 arg = value_ind (arg);
7531 t = t1;
7532 }
4c4b4cd2 7533 else
76a01679 7534 break;
4c4b4cd2 7535 }
14f9c5c9 7536
4c4b4cd2 7537 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7538 goto BadValue;
14f9c5c9 7539
4c4b4cd2
PH
7540 if (t1 == t)
7541 v = ada_search_struct_field (name, arg, 0, t);
7542 else
7543 {
7544 int bit_offset, bit_size, byte_offset;
7545 struct type *field_type;
7546 CORE_ADDR address;
7547
76a01679 7548 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7549 address = value_address (ada_value_ind (arg));
4c4b4cd2 7550 else
b50d69b5 7551 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7552
828d5846
XR
7553 /* Check to see if this is a tagged type. We also need to handle
7554 the case where the type is a reference to a tagged type, but
7555 we have to be careful to exclude pointers to tagged types.
7556 The latter should be shown as usual (as a pointer), whereas
7557 a reference should mostly be transparent to the user. */
7558
7559 if (ada_is_tagged_type (t1, 0)
7560 || (TYPE_CODE (t1) == TYPE_CODE_REF
7561 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7562 {
7563 /* We first try to find the searched field in the current type.
7564 If not found then let's look in the fixed type. */
7565
7566 if (!find_struct_field (name, t1, 0,
7567 &field_type, &byte_offset, &bit_offset,
7568 &bit_size, NULL))
1f5d1570
JG
7569 check_tag = 1;
7570 else
7571 check_tag = 0;
828d5846
XR
7572 }
7573 else
1f5d1570
JG
7574 check_tag = 0;
7575
7576 /* Convert to fixed type in all cases, so that we have proper
7577 offsets to each field in unconstrained record types. */
7578 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7579 address, NULL, check_tag);
828d5846 7580
76a01679
JB
7581 if (find_struct_field (name, t1, 0,
7582 &field_type, &byte_offset, &bit_offset,
52ce6436 7583 &bit_size, NULL))
76a01679
JB
7584 {
7585 if (bit_size != 0)
7586 {
714e53ab
PH
7587 if (TYPE_CODE (t) == TYPE_CODE_REF)
7588 arg = ada_coerce_ref (arg);
7589 else
7590 arg = ada_value_ind (arg);
76a01679
JB
7591 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7592 bit_offset, bit_size,
7593 field_type);
7594 }
7595 else
f5938064 7596 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7597 }
7598 }
7599
03ee6b2e
PH
7600 if (v != NULL || no_err)
7601 return v;
7602 else
323e0a4a 7603 error (_("There is no member named %s."), name);
14f9c5c9 7604
03ee6b2e
PH
7605 BadValue:
7606 if (no_err)
7607 return NULL;
7608 else
0963b4bd
MS
7609 error (_("Attempt to extract a component of "
7610 "a value that is not a record."));
14f9c5c9
AS
7611}
7612
3b4de39c 7613/* Return a string representation of type TYPE. */
99bbb428 7614
3b4de39c 7615static std::string
99bbb428
PA
7616type_as_string (struct type *type)
7617{
d7e74731 7618 string_file tmp_stream;
99bbb428 7619
d7e74731 7620 type_print (type, "", &tmp_stream, -1);
99bbb428 7621
d7e74731 7622 return std::move (tmp_stream.string ());
99bbb428
PA
7623}
7624
14f9c5c9 7625/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7626 If DISPP is non-null, add its byte displacement from the beginning of a
7627 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7628 work for packed fields).
7629
7630 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7631 followed by "___".
14f9c5c9 7632
0963b4bd 7633 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7634 be a (pointer or reference)+ to a struct or union, and the
7635 ultimate target type will be searched.
14f9c5c9
AS
7636
7637 Looks recursively into variant clauses and parent types.
7638
828d5846
XR
7639 In the case of homonyms in the tagged types, please refer to the
7640 long explanation in find_struct_field's function documentation.
7641
4c4b4cd2
PH
7642 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7643 TYPE is not a type of the right kind. */
14f9c5c9 7644
4c4b4cd2 7645static struct type *
a121b7c1 7646ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7647 int noerr)
14f9c5c9
AS
7648{
7649 int i;
828d5846 7650 int parent_offset = -1;
14f9c5c9
AS
7651
7652 if (name == NULL)
7653 goto BadName;
7654
76a01679 7655 if (refok && type != NULL)
4c4b4cd2
PH
7656 while (1)
7657 {
61ee279c 7658 type = ada_check_typedef (type);
76a01679
JB
7659 if (TYPE_CODE (type) != TYPE_CODE_PTR
7660 && TYPE_CODE (type) != TYPE_CODE_REF)
7661 break;
7662 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7663 }
14f9c5c9 7664
76a01679 7665 if (type == NULL
1265e4aa
JB
7666 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7667 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7668 {
4c4b4cd2 7669 if (noerr)
76a01679 7670 return NULL;
99bbb428 7671
3b4de39c
PA
7672 error (_("Type %s is not a structure or union type"),
7673 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7674 }
7675
7676 type = to_static_fixed_type (type);
7677
7678 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7679 {
0d5cff50 7680 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7681 struct type *t;
d2e4a39e 7682
14f9c5c9 7683 if (t_field_name == NULL)
4c4b4cd2 7684 continue;
14f9c5c9 7685
828d5846
XR
7686 else if (ada_is_parent_field (type, i))
7687 {
7688 /* This is a field pointing us to the parent type of a tagged
7689 type. As hinted in this function's documentation, we give
7690 preference to fields in the current record first, so what
7691 we do here is just record the index of this field before
7692 we skip it. If it turns out we couldn't find our field
7693 in the current record, then we'll get back to it and search
7694 inside it whether the field might exist in the parent. */
7695
7696 parent_offset = i;
7697 continue;
7698 }
7699
14f9c5c9 7700 else if (field_name_match (t_field_name, name))
988f6b3d 7701 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7702
7703 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7704 {
4c4b4cd2 7705 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7706 0, 1);
4c4b4cd2 7707 if (t != NULL)
988f6b3d 7708 return t;
4c4b4cd2 7709 }
14f9c5c9
AS
7710
7711 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7712 {
7713 int j;
5b4ee69b
MS
7714 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7715 i));
4c4b4cd2
PH
7716
7717 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7718 {
b1f33ddd
JB
7719 /* FIXME pnh 2008/01/26: We check for a field that is
7720 NOT wrapped in a struct, since the compiler sometimes
7721 generates these for unchecked variant types. Revisit
0963b4bd 7722 if the compiler changes this practice. */
0d5cff50 7723 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7724
b1f33ddd
JB
7725 if (v_field_name != NULL
7726 && field_name_match (v_field_name, name))
460efde1 7727 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7728 else
0963b4bd
MS
7729 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7730 j),
988f6b3d 7731 name, 0, 1);
b1f33ddd 7732
4c4b4cd2 7733 if (t != NULL)
988f6b3d 7734 return t;
4c4b4cd2
PH
7735 }
7736 }
14f9c5c9
AS
7737
7738 }
7739
828d5846
XR
7740 /* Field not found so far. If this is a tagged type which
7741 has a parent, try finding that field in the parent now. */
7742
7743 if (parent_offset != -1)
7744 {
7745 struct type *t;
7746
7747 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7748 name, 0, 1);
7749 if (t != NULL)
7750 return t;
7751 }
7752
14f9c5c9 7753BadName:
d2e4a39e 7754 if (!noerr)
14f9c5c9 7755 {
2b2798cc 7756 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7757
7758 error (_("Type %s has no component named %s"),
3b4de39c 7759 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7760 }
7761
7762 return NULL;
7763}
7764
b1f33ddd
JB
7765/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7766 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7767 represents an unchecked union (that is, the variant part of a
0963b4bd 7768 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7769
7770static int
7771is_unchecked_variant (struct type *var_type, struct type *outer_type)
7772{
a121b7c1 7773 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7774
988f6b3d 7775 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7776}
7777
7778
14f9c5c9
AS
7779/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7780 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7781 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7782 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7783
d2e4a39e 7784int
ebf56fd3 7785ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7786 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7787{
7788 int others_clause;
7789 int i;
a121b7c1 7790 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7791 struct value *outer;
7792 struct value *discrim;
14f9c5c9
AS
7793 LONGEST discrim_val;
7794
012370f6
TT
7795 /* Using plain value_from_contents_and_address here causes problems
7796 because we will end up trying to resolve a type that is currently
7797 being constructed. */
7798 outer = value_from_contents_and_address_unresolved (outer_type,
7799 outer_valaddr, 0);
0c281816
JB
7800 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7801 if (discrim == NULL)
14f9c5c9 7802 return -1;
0c281816 7803 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7804
7805 others_clause = -1;
7806 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7807 {
7808 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7809 others_clause = i;
14f9c5c9 7810 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7811 return i;
14f9c5c9
AS
7812 }
7813
7814 return others_clause;
7815}
d2e4a39e 7816\f
14f9c5c9
AS
7817
7818
4c4b4cd2 7819 /* Dynamic-Sized Records */
14f9c5c9
AS
7820
7821/* Strategy: The type ostensibly attached to a value with dynamic size
7822 (i.e., a size that is not statically recorded in the debugging
7823 data) does not accurately reflect the size or layout of the value.
7824 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7825 conventional types that are constructed on the fly. */
14f9c5c9
AS
7826
7827/* There is a subtle and tricky problem here. In general, we cannot
7828 determine the size of dynamic records without its data. However,
7829 the 'struct value' data structure, which GDB uses to represent
7830 quantities in the inferior process (the target), requires the size
7831 of the type at the time of its allocation in order to reserve space
7832 for GDB's internal copy of the data. That's why the
7833 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7834 rather than struct value*s.
14f9c5c9
AS
7835
7836 However, GDB's internal history variables ($1, $2, etc.) are
7837 struct value*s containing internal copies of the data that are not, in
7838 general, the same as the data at their corresponding addresses in
7839 the target. Fortunately, the types we give to these values are all
7840 conventional, fixed-size types (as per the strategy described
7841 above), so that we don't usually have to perform the
7842 'to_fixed_xxx_type' conversions to look at their values.
7843 Unfortunately, there is one exception: if one of the internal
7844 history variables is an array whose elements are unconstrained
7845 records, then we will need to create distinct fixed types for each
7846 element selected. */
7847
7848/* The upshot of all of this is that many routines take a (type, host
7849 address, target address) triple as arguments to represent a value.
7850 The host address, if non-null, is supposed to contain an internal
7851 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7852 target at the target address. */
14f9c5c9
AS
7853
7854/* Assuming that VAL0 represents a pointer value, the result of
7855 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7856 dynamic-sized types. */
14f9c5c9 7857
d2e4a39e
AS
7858struct value *
7859ada_value_ind (struct value *val0)
14f9c5c9 7860{
c48db5ca 7861 struct value *val = value_ind (val0);
5b4ee69b 7862
b50d69b5
JG
7863 if (ada_is_tagged_type (value_type (val), 0))
7864 val = ada_tag_value_at_base_address (val);
7865
4c4b4cd2 7866 return ada_to_fixed_value (val);
14f9c5c9
AS
7867}
7868
7869/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7870 qualifiers on VAL0. */
7871
d2e4a39e
AS
7872static struct value *
7873ada_coerce_ref (struct value *val0)
7874{
df407dfe 7875 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7876 {
7877 struct value *val = val0;
5b4ee69b 7878
994b9211 7879 val = coerce_ref (val);
b50d69b5
JG
7880
7881 if (ada_is_tagged_type (value_type (val), 0))
7882 val = ada_tag_value_at_base_address (val);
7883
4c4b4cd2 7884 return ada_to_fixed_value (val);
d2e4a39e
AS
7885 }
7886 else
14f9c5c9
AS
7887 return val0;
7888}
7889
7890/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7891 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7892
7893static unsigned int
ebf56fd3 7894align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7895{
7896 return (off + alignment - 1) & ~(alignment - 1);
7897}
7898
4c4b4cd2 7899/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7900
7901static unsigned int
ebf56fd3 7902field_alignment (struct type *type, int f)
14f9c5c9 7903{
d2e4a39e 7904 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7905 int len;
14f9c5c9
AS
7906 int align_offset;
7907
64a1bf19
JB
7908 /* The field name should never be null, unless the debugging information
7909 is somehow malformed. In this case, we assume the field does not
7910 require any alignment. */
7911 if (name == NULL)
7912 return 1;
7913
7914 len = strlen (name);
7915
4c4b4cd2
PH
7916 if (!isdigit (name[len - 1]))
7917 return 1;
14f9c5c9 7918
d2e4a39e 7919 if (isdigit (name[len - 2]))
14f9c5c9
AS
7920 align_offset = len - 2;
7921 else
7922 align_offset = len - 1;
7923
61012eef 7924 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7925 return TARGET_CHAR_BIT;
7926
4c4b4cd2
PH
7927 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7928}
7929
852dff6c 7930/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7931
852dff6c
JB
7932static struct symbol *
7933ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7934{
7935 struct symbol *sym;
7936
7937 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7938 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7939 return sym;
7940
4186eb54
KS
7941 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7942 return sym;
14f9c5c9
AS
7943}
7944
dddfab26
UW
7945/* Find a type named NAME. Ignores ambiguity. This routine will look
7946 solely for types defined by debug info, it will not search the GDB
7947 primitive types. */
4c4b4cd2 7948
852dff6c 7949static struct type *
ebf56fd3 7950ada_find_any_type (const char *name)
14f9c5c9 7951{
852dff6c 7952 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7953
14f9c5c9 7954 if (sym != NULL)
dddfab26 7955 return SYMBOL_TYPE (sym);
14f9c5c9 7956
dddfab26 7957 return NULL;
14f9c5c9
AS
7958}
7959
739593e0
JB
7960/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7961 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7962 symbol, in which case it is returned. Otherwise, this looks for
7963 symbols whose name is that of NAME_SYM suffixed with "___XR".
7964 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7965
7966struct symbol *
270140bd 7967ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7968{
739593e0 7969 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7970 struct symbol *sym;
7971
739593e0
JB
7972 if (strstr (name, "___XR") != NULL)
7973 return name_sym;
7974
aeb5907d
JB
7975 sym = find_old_style_renaming_symbol (name, block);
7976
7977 if (sym != NULL)
7978 return sym;
7979
0963b4bd 7980 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7981 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7982 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7983 return sym;
7984 else
7985 return NULL;
7986}
7987
7988static struct symbol *
270140bd 7989find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7990{
7f0df278 7991 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7992 char *rename;
7993
7994 if (function_sym != NULL)
7995 {
7996 /* If the symbol is defined inside a function, NAME is not fully
7997 qualified. This means we need to prepend the function name
7998 as well as adding the ``___XR'' suffix to build the name of
7999 the associated renaming symbol. */
0d5cff50 8000 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
8001 /* Function names sometimes contain suffixes used
8002 for instance to qualify nested subprograms. When building
8003 the XR type name, we need to make sure that this suffix is
8004 not included. So do not include any suffix in the function
8005 name length below. */
69fadcdf 8006 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
8007 const int rename_len = function_name_len + 2 /* "__" */
8008 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 8009
529cad9c 8010 /* Strip the suffix if necessary. */
69fadcdf
JB
8011 ada_remove_trailing_digits (function_name, &function_name_len);
8012 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8013 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 8014
4c4b4cd2
PH
8015 /* Library-level functions are a special case, as GNAT adds
8016 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 8017 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
8018 have this prefix, so we need to skip this prefix if present. */
8019 if (function_name_len > 5 /* "_ada_" */
8020 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
8021 {
8022 function_name += 5;
8023 function_name_len -= 5;
8024 }
4c4b4cd2
PH
8025
8026 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
8027 strncpy (rename, function_name, function_name_len);
8028 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8029 "__%s___XR", name);
4c4b4cd2
PH
8030 }
8031 else
8032 {
8033 const int rename_len = strlen (name) + 6;
5b4ee69b 8034
4c4b4cd2 8035 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 8036 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
8037 }
8038
852dff6c 8039 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
8040}
8041
14f9c5c9 8042/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 8043 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 8044 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
8045 otherwise return 0. */
8046
14f9c5c9 8047int
d2e4a39e 8048ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
8049{
8050 if (type1 == NULL)
8051 return 1;
8052 else if (type0 == NULL)
8053 return 0;
8054 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8055 return 1;
8056 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8057 return 0;
4c4b4cd2
PH
8058 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8059 return 1;
ad82864c 8060 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8061 return 1;
4c4b4cd2
PH
8062 else if (ada_is_array_descriptor_type (type0)
8063 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8064 return 1;
aeb5907d
JB
8065 else
8066 {
a737d952
TT
8067 const char *type0_name = TYPE_NAME (type0);
8068 const char *type1_name = TYPE_NAME (type1);
aeb5907d
JB
8069
8070 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8071 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8072 return 1;
8073 }
14f9c5c9
AS
8074 return 0;
8075}
8076
e86ca25f
TT
8077/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
8078 null. */
4c4b4cd2 8079
0d5cff50 8080const char *
d2e4a39e 8081ada_type_name (struct type *type)
14f9c5c9 8082{
d2e4a39e 8083 if (type == NULL)
14f9c5c9 8084 return NULL;
e86ca25f 8085 return TYPE_NAME (type);
14f9c5c9
AS
8086}
8087
b4ba55a1
JB
8088/* Search the list of "descriptive" types associated to TYPE for a type
8089 whose name is NAME. */
8090
8091static struct type *
8092find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8093{
931e5bc3 8094 struct type *result, *tmp;
b4ba55a1 8095
c6044dd1
JB
8096 if (ada_ignore_descriptive_types_p)
8097 return NULL;
8098
b4ba55a1
JB
8099 /* If there no descriptive-type info, then there is no parallel type
8100 to be found. */
8101 if (!HAVE_GNAT_AUX_INFO (type))
8102 return NULL;
8103
8104 result = TYPE_DESCRIPTIVE_TYPE (type);
8105 while (result != NULL)
8106 {
0d5cff50 8107 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8108
8109 if (result_name == NULL)
8110 {
8111 warning (_("unexpected null name on descriptive type"));
8112 return NULL;
8113 }
8114
8115 /* If the names match, stop. */
8116 if (strcmp (result_name, name) == 0)
8117 break;
8118
8119 /* Otherwise, look at the next item on the list, if any. */
8120 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8121 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8122 else
8123 tmp = NULL;
8124
8125 /* If not found either, try after having resolved the typedef. */
8126 if (tmp != NULL)
8127 result = tmp;
b4ba55a1 8128 else
931e5bc3 8129 {
f168693b 8130 result = check_typedef (result);
931e5bc3
JG
8131 if (HAVE_GNAT_AUX_INFO (result))
8132 result = TYPE_DESCRIPTIVE_TYPE (result);
8133 else
8134 result = NULL;
8135 }
b4ba55a1
JB
8136 }
8137
8138 /* If we didn't find a match, see whether this is a packed array. With
8139 older compilers, the descriptive type information is either absent or
8140 irrelevant when it comes to packed arrays so the above lookup fails.
8141 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8142 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8143 return ada_find_any_type (name);
8144
8145 return result;
8146}
8147
8148/* Find a parallel type to TYPE with the specified NAME, using the
8149 descriptive type taken from the debugging information, if available,
8150 and otherwise using the (slower) name-based method. */
8151
8152static struct type *
8153ada_find_parallel_type_with_name (struct type *type, const char *name)
8154{
8155 struct type *result = NULL;
8156
8157 if (HAVE_GNAT_AUX_INFO (type))
8158 result = find_parallel_type_by_descriptive_type (type, name);
8159 else
8160 result = ada_find_any_type (name);
8161
8162 return result;
8163}
8164
8165/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8166 SUFFIX to the name of TYPE. */
14f9c5c9 8167
d2e4a39e 8168struct type *
ebf56fd3 8169ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8170{
0d5cff50 8171 char *name;
fe978cb0 8172 const char *type_name = ada_type_name (type);
14f9c5c9 8173 int len;
d2e4a39e 8174
fe978cb0 8175 if (type_name == NULL)
14f9c5c9
AS
8176 return NULL;
8177
fe978cb0 8178 len = strlen (type_name);
14f9c5c9 8179
b4ba55a1 8180 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8181
fe978cb0 8182 strcpy (name, type_name);
14f9c5c9
AS
8183 strcpy (name + len, suffix);
8184
b4ba55a1 8185 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8186}
8187
14f9c5c9 8188/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8189 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8190
d2e4a39e
AS
8191static struct type *
8192dynamic_template_type (struct type *type)
14f9c5c9 8193{
61ee279c 8194 type = ada_check_typedef (type);
14f9c5c9
AS
8195
8196 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8197 || ada_type_name (type) == NULL)
14f9c5c9 8198 return NULL;
d2e4a39e 8199 else
14f9c5c9
AS
8200 {
8201 int len = strlen (ada_type_name (type));
5b4ee69b 8202
4c4b4cd2
PH
8203 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8204 return type;
14f9c5c9 8205 else
4c4b4cd2 8206 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8207 }
8208}
8209
8210/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8211 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8212
d2e4a39e
AS
8213static int
8214is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8215{
8216 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8217
d2e4a39e 8218 return name != NULL
14f9c5c9
AS
8219 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8220 && strstr (name, "___XVL") != NULL;
8221}
8222
4c4b4cd2
PH
8223/* The index of the variant field of TYPE, or -1 if TYPE does not
8224 represent a variant record type. */
14f9c5c9 8225
d2e4a39e 8226static int
4c4b4cd2 8227variant_field_index (struct type *type)
14f9c5c9
AS
8228{
8229 int f;
8230
4c4b4cd2
PH
8231 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8232 return -1;
8233
8234 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8235 {
8236 if (ada_is_variant_part (type, f))
8237 return f;
8238 }
8239 return -1;
14f9c5c9
AS
8240}
8241
4c4b4cd2
PH
8242/* A record type with no fields. */
8243
d2e4a39e 8244static struct type *
fe978cb0 8245empty_record (struct type *templ)
14f9c5c9 8246{
fe978cb0 8247 struct type *type = alloc_type_copy (templ);
5b4ee69b 8248
14f9c5c9
AS
8249 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8250 TYPE_NFIELDS (type) = 0;
8251 TYPE_FIELDS (type) = NULL;
b1f33ddd 8252 INIT_CPLUS_SPECIFIC (type);
14f9c5c9 8253 TYPE_NAME (type) = "<empty>";
14f9c5c9
AS
8254 TYPE_LENGTH (type) = 0;
8255 return type;
8256}
8257
8258/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8259 the value of type TYPE at VALADDR or ADDRESS (see comments at
8260 the beginning of this section) VAL according to GNAT conventions.
8261 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8262 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8263 an outer-level type (i.e., as opposed to a branch of a variant.) A
8264 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8265 of the variant.
14f9c5c9 8266
4c4b4cd2
PH
8267 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8268 length are not statically known are discarded. As a consequence,
8269 VALADDR, ADDRESS and DVAL0 are ignored.
8270
8271 NOTE: Limitations: For now, we assume that dynamic fields and
8272 variants occupy whole numbers of bytes. However, they need not be
8273 byte-aligned. */
8274
8275struct type *
10a2c479 8276ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8277 const gdb_byte *valaddr,
4c4b4cd2
PH
8278 CORE_ADDR address, struct value *dval0,
8279 int keep_dynamic_fields)
14f9c5c9 8280{
d2e4a39e
AS
8281 struct value *mark = value_mark ();
8282 struct value *dval;
8283 struct type *rtype;
14f9c5c9 8284 int nfields, bit_len;
4c4b4cd2 8285 int variant_field;
14f9c5c9 8286 long off;
d94e4f4f 8287 int fld_bit_len;
14f9c5c9
AS
8288 int f;
8289
4c4b4cd2
PH
8290 /* Compute the number of fields in this record type that are going
8291 to be processed: unless keep_dynamic_fields, this includes only
8292 fields whose position and length are static will be processed. */
8293 if (keep_dynamic_fields)
8294 nfields = TYPE_NFIELDS (type);
8295 else
8296 {
8297 nfields = 0;
76a01679 8298 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8299 && !ada_is_variant_part (type, nfields)
8300 && !is_dynamic_field (type, nfields))
8301 nfields++;
8302 }
8303
e9bb382b 8304 rtype = alloc_type_copy (type);
14f9c5c9
AS
8305 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8306 INIT_CPLUS_SPECIFIC (rtype);
8307 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8308 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8309 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8310 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8311 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8312 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8313
d2e4a39e
AS
8314 off = 0;
8315 bit_len = 0;
4c4b4cd2
PH
8316 variant_field = -1;
8317
14f9c5c9
AS
8318 for (f = 0; f < nfields; f += 1)
8319 {
6c038f32
PH
8320 off = align_value (off, field_alignment (type, f))
8321 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8322 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8323 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8324
d2e4a39e 8325 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8326 {
8327 variant_field = f;
d94e4f4f 8328 fld_bit_len = 0;
4c4b4cd2 8329 }
14f9c5c9 8330 else if (is_dynamic_field (type, f))
4c4b4cd2 8331 {
284614f0
JB
8332 const gdb_byte *field_valaddr = valaddr;
8333 CORE_ADDR field_address = address;
8334 struct type *field_type =
8335 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8336
4c4b4cd2 8337 if (dval0 == NULL)
b5304971
JG
8338 {
8339 /* rtype's length is computed based on the run-time
8340 value of discriminants. If the discriminants are not
8341 initialized, the type size may be completely bogus and
0963b4bd 8342 GDB may fail to allocate a value for it. So check the
b5304971 8343 size first before creating the value. */
c1b5a1a6 8344 ada_ensure_varsize_limit (rtype);
012370f6
TT
8345 /* Using plain value_from_contents_and_address here
8346 causes problems because we will end up trying to
8347 resolve a type that is currently being
8348 constructed. */
8349 dval = value_from_contents_and_address_unresolved (rtype,
8350 valaddr,
8351 address);
9f1f738a 8352 rtype = value_type (dval);
b5304971 8353 }
4c4b4cd2
PH
8354 else
8355 dval = dval0;
8356
284614f0
JB
8357 /* If the type referenced by this field is an aligner type, we need
8358 to unwrap that aligner type, because its size might not be set.
8359 Keeping the aligner type would cause us to compute the wrong
8360 size for this field, impacting the offset of the all the fields
8361 that follow this one. */
8362 if (ada_is_aligner_type (field_type))
8363 {
8364 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8365
8366 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8367 field_address = cond_offset_target (field_address, field_offset);
8368 field_type = ada_aligned_type (field_type);
8369 }
8370
8371 field_valaddr = cond_offset_host (field_valaddr,
8372 off / TARGET_CHAR_BIT);
8373 field_address = cond_offset_target (field_address,
8374 off / TARGET_CHAR_BIT);
8375
8376 /* Get the fixed type of the field. Note that, in this case,
8377 we do not want to get the real type out of the tag: if
8378 the current field is the parent part of a tagged record,
8379 we will get the tag of the object. Clearly wrong: the real
8380 type of the parent is not the real type of the child. We
8381 would end up in an infinite loop. */
8382 field_type = ada_get_base_type (field_type);
8383 field_type = ada_to_fixed_type (field_type, field_valaddr,
8384 field_address, dval, 0);
27f2a97b
JB
8385 /* If the field size is already larger than the maximum
8386 object size, then the record itself will necessarily
8387 be larger than the maximum object size. We need to make
8388 this check now, because the size might be so ridiculously
8389 large (due to an uninitialized variable in the inferior)
8390 that it would cause an overflow when adding it to the
8391 record size. */
c1b5a1a6 8392 ada_ensure_varsize_limit (field_type);
284614f0
JB
8393
8394 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8395 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8396 /* The multiplication can potentially overflow. But because
8397 the field length has been size-checked just above, and
8398 assuming that the maximum size is a reasonable value,
8399 an overflow should not happen in practice. So rather than
8400 adding overflow recovery code to this already complex code,
8401 we just assume that it's not going to happen. */
d94e4f4f 8402 fld_bit_len =
4c4b4cd2
PH
8403 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8404 }
14f9c5c9 8405 else
4c4b4cd2 8406 {
5ded5331
JB
8407 /* Note: If this field's type is a typedef, it is important
8408 to preserve the typedef layer.
8409
8410 Otherwise, we might be transforming a typedef to a fat
8411 pointer (encoding a pointer to an unconstrained array),
8412 into a basic fat pointer (encoding an unconstrained
8413 array). As both types are implemented using the same
8414 structure, the typedef is the only clue which allows us
8415 to distinguish between the two options. Stripping it
8416 would prevent us from printing this field appropriately. */
8417 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8418 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8419 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8420 fld_bit_len =
4c4b4cd2
PH
8421 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8422 else
5ded5331
JB
8423 {
8424 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8425
8426 /* We need to be careful of typedefs when computing
8427 the length of our field. If this is a typedef,
8428 get the length of the target type, not the length
8429 of the typedef. */
8430 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8431 field_type = ada_typedef_target_type (field_type);
8432
8433 fld_bit_len =
8434 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8435 }
4c4b4cd2 8436 }
14f9c5c9 8437 if (off + fld_bit_len > bit_len)
4c4b4cd2 8438 bit_len = off + fld_bit_len;
d94e4f4f 8439 off += fld_bit_len;
4c4b4cd2
PH
8440 TYPE_LENGTH (rtype) =
8441 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8442 }
4c4b4cd2
PH
8443
8444 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8445 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8446 the record. This can happen in the presence of representation
8447 clauses. */
8448 if (variant_field >= 0)
8449 {
8450 struct type *branch_type;
8451
8452 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8453
8454 if (dval0 == NULL)
9f1f738a 8455 {
012370f6
TT
8456 /* Using plain value_from_contents_and_address here causes
8457 problems because we will end up trying to resolve a type
8458 that is currently being constructed. */
8459 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8460 address);
9f1f738a
SA
8461 rtype = value_type (dval);
8462 }
4c4b4cd2
PH
8463 else
8464 dval = dval0;
8465
8466 branch_type =
8467 to_fixed_variant_branch_type
8468 (TYPE_FIELD_TYPE (type, variant_field),
8469 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8470 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8471 if (branch_type == NULL)
8472 {
8473 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8474 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8475 TYPE_NFIELDS (rtype) -= 1;
8476 }
8477 else
8478 {
8479 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8480 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8481 fld_bit_len =
8482 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8483 TARGET_CHAR_BIT;
8484 if (off + fld_bit_len > bit_len)
8485 bit_len = off + fld_bit_len;
8486 TYPE_LENGTH (rtype) =
8487 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8488 }
8489 }
8490
714e53ab
PH
8491 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8492 should contain the alignment of that record, which should be a strictly
8493 positive value. If null or negative, then something is wrong, most
8494 probably in the debug info. In that case, we don't round up the size
0963b4bd 8495 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8496 the current RTYPE length might be good enough for our purposes. */
8497 if (TYPE_LENGTH (type) <= 0)
8498 {
323e0a4a
AC
8499 if (TYPE_NAME (rtype))
8500 warning (_("Invalid type size for `%s' detected: %d."),
8501 TYPE_NAME (rtype), TYPE_LENGTH (type));
8502 else
8503 warning (_("Invalid type size for <unnamed> detected: %d."),
8504 TYPE_LENGTH (type));
714e53ab
PH
8505 }
8506 else
8507 {
8508 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8509 TYPE_LENGTH (type));
8510 }
14f9c5c9
AS
8511
8512 value_free_to_mark (mark);
d2e4a39e 8513 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8514 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8515 return rtype;
8516}
8517
4c4b4cd2
PH
8518/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8519 of 1. */
14f9c5c9 8520
d2e4a39e 8521static struct type *
fc1a4b47 8522template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8523 CORE_ADDR address, struct value *dval0)
8524{
8525 return ada_template_to_fixed_record_type_1 (type, valaddr,
8526 address, dval0, 1);
8527}
8528
8529/* An ordinary record type in which ___XVL-convention fields and
8530 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8531 static approximations, containing all possible fields. Uses
8532 no runtime values. Useless for use in values, but that's OK,
8533 since the results are used only for type determinations. Works on both
8534 structs and unions. Representation note: to save space, we memorize
8535 the result of this function in the TYPE_TARGET_TYPE of the
8536 template type. */
8537
8538static struct type *
8539template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8540{
8541 struct type *type;
8542 int nfields;
8543 int f;
8544
9e195661
PMR
8545 /* No need no do anything if the input type is already fixed. */
8546 if (TYPE_FIXED_INSTANCE (type0))
8547 return type0;
8548
8549 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8550 if (TYPE_TARGET_TYPE (type0) != NULL)
8551 return TYPE_TARGET_TYPE (type0);
8552
9e195661 8553 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8554 type = type0;
9e195661
PMR
8555 nfields = TYPE_NFIELDS (type0);
8556
8557 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8558 recompute all over next time. */
8559 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8560
8561 for (f = 0; f < nfields; f += 1)
8562 {
460efde1 8563 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8564 struct type *new_type;
14f9c5c9 8565
4c4b4cd2 8566 if (is_dynamic_field (type0, f))
460efde1
JB
8567 {
8568 field_type = ada_check_typedef (field_type);
8569 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8570 }
14f9c5c9 8571 else
f192137b 8572 new_type = static_unwrap_type (field_type);
9e195661
PMR
8573
8574 if (new_type != field_type)
8575 {
8576 /* Clone TYPE0 only the first time we get a new field type. */
8577 if (type == type0)
8578 {
8579 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8580 TYPE_CODE (type) = TYPE_CODE (type0);
8581 INIT_CPLUS_SPECIFIC (type);
8582 TYPE_NFIELDS (type) = nfields;
8583 TYPE_FIELDS (type) = (struct field *)
8584 TYPE_ALLOC (type, nfields * sizeof (struct field));
8585 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8586 sizeof (struct field) * nfields);
8587 TYPE_NAME (type) = ada_type_name (type0);
9e195661
PMR
8588 TYPE_FIXED_INSTANCE (type) = 1;
8589 TYPE_LENGTH (type) = 0;
8590 }
8591 TYPE_FIELD_TYPE (type, f) = new_type;
8592 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8593 }
14f9c5c9 8594 }
9e195661 8595
14f9c5c9
AS
8596 return type;
8597}
8598
4c4b4cd2 8599/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8600 whose address in memory is ADDRESS, returns a revision of TYPE,
8601 which should be a non-dynamic-sized record, in which the variant
8602 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8603 for discriminant values in DVAL0, which can be NULL if the record
8604 contains the necessary discriminant values. */
8605
d2e4a39e 8606static struct type *
fc1a4b47 8607to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8608 CORE_ADDR address, struct value *dval0)
14f9c5c9 8609{
d2e4a39e 8610 struct value *mark = value_mark ();
4c4b4cd2 8611 struct value *dval;
d2e4a39e 8612 struct type *rtype;
14f9c5c9
AS
8613 struct type *branch_type;
8614 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8615 int variant_field = variant_field_index (type);
14f9c5c9 8616
4c4b4cd2 8617 if (variant_field == -1)
14f9c5c9
AS
8618 return type;
8619
4c4b4cd2 8620 if (dval0 == NULL)
9f1f738a
SA
8621 {
8622 dval = value_from_contents_and_address (type, valaddr, address);
8623 type = value_type (dval);
8624 }
4c4b4cd2
PH
8625 else
8626 dval = dval0;
8627
e9bb382b 8628 rtype = alloc_type_copy (type);
14f9c5c9 8629 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8630 INIT_CPLUS_SPECIFIC (rtype);
8631 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8632 TYPE_FIELDS (rtype) =
8633 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8634 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8635 sizeof (struct field) * nfields);
14f9c5c9 8636 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8637 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8638 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8639
4c4b4cd2
PH
8640 branch_type = to_fixed_variant_branch_type
8641 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8642 cond_offset_host (valaddr,
4c4b4cd2
PH
8643 TYPE_FIELD_BITPOS (type, variant_field)
8644 / TARGET_CHAR_BIT),
d2e4a39e 8645 cond_offset_target (address,
4c4b4cd2
PH
8646 TYPE_FIELD_BITPOS (type, variant_field)
8647 / TARGET_CHAR_BIT), dval);
d2e4a39e 8648 if (branch_type == NULL)
14f9c5c9 8649 {
4c4b4cd2 8650 int f;
5b4ee69b 8651
4c4b4cd2
PH
8652 for (f = variant_field + 1; f < nfields; f += 1)
8653 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8654 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8655 }
8656 else
8657 {
4c4b4cd2
PH
8658 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8659 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8660 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8661 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8662 }
4c4b4cd2 8663 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8664
4c4b4cd2 8665 value_free_to_mark (mark);
14f9c5c9
AS
8666 return rtype;
8667}
8668
8669/* An ordinary record type (with fixed-length fields) that describes
8670 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8671 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8672 should be in DVAL, a record value; it may be NULL if the object
8673 at ADDR itself contains any necessary discriminant values.
8674 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8675 values from the record are needed. Except in the case that DVAL,
8676 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8677 unchecked) is replaced by a particular branch of the variant.
8678
8679 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8680 is questionable and may be removed. It can arise during the
8681 processing of an unconstrained-array-of-record type where all the
8682 variant branches have exactly the same size. This is because in
8683 such cases, the compiler does not bother to use the XVS convention
8684 when encoding the record. I am currently dubious of this
8685 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8686
d2e4a39e 8687static struct type *
fc1a4b47 8688to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8689 CORE_ADDR address, struct value *dval)
14f9c5c9 8690{
d2e4a39e 8691 struct type *templ_type;
14f9c5c9 8692
876cecd0 8693 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8694 return type0;
8695
d2e4a39e 8696 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8697
8698 if (templ_type != NULL)
8699 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8700 else if (variant_field_index (type0) >= 0)
8701 {
8702 if (dval == NULL && valaddr == NULL && address == 0)
8703 return type0;
8704 return to_record_with_fixed_variant_part (type0, valaddr, address,
8705 dval);
8706 }
14f9c5c9
AS
8707 else
8708 {
876cecd0 8709 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8710 return type0;
8711 }
8712
8713}
8714
8715/* An ordinary record type (with fixed-length fields) that describes
8716 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8717 union type. Any necessary discriminants' values should be in DVAL,
8718 a record value. That is, this routine selects the appropriate
8719 branch of the union at ADDR according to the discriminant value
b1f33ddd 8720 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8721 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8722
d2e4a39e 8723static struct type *
fc1a4b47 8724to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8725 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8726{
8727 int which;
d2e4a39e
AS
8728 struct type *templ_type;
8729 struct type *var_type;
14f9c5c9
AS
8730
8731 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8732 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8733 else
14f9c5c9
AS
8734 var_type = var_type0;
8735
8736 templ_type = ada_find_parallel_type (var_type, "___XVU");
8737
8738 if (templ_type != NULL)
8739 var_type = templ_type;
8740
b1f33ddd
JB
8741 if (is_unchecked_variant (var_type, value_type (dval)))
8742 return var_type0;
d2e4a39e
AS
8743 which =
8744 ada_which_variant_applies (var_type,
0fd88904 8745 value_type (dval), value_contents (dval));
14f9c5c9
AS
8746
8747 if (which < 0)
e9bb382b 8748 return empty_record (var_type);
14f9c5c9 8749 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8750 return to_fixed_record_type
d2e4a39e
AS
8751 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8752 valaddr, address, dval);
4c4b4cd2 8753 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8754 return
8755 to_fixed_record_type
8756 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8757 else
8758 return TYPE_FIELD_TYPE (var_type, which);
8759}
8760
8908fca5
JB
8761/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8762 ENCODING_TYPE, a type following the GNAT conventions for discrete
8763 type encodings, only carries redundant information. */
8764
8765static int
8766ada_is_redundant_range_encoding (struct type *range_type,
8767 struct type *encoding_type)
8768{
108d56a4 8769 const char *bounds_str;
8908fca5
JB
8770 int n;
8771 LONGEST lo, hi;
8772
8773 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8774
005e2509
JB
8775 if (TYPE_CODE (get_base_type (range_type))
8776 != TYPE_CODE (get_base_type (encoding_type)))
8777 {
8778 /* The compiler probably used a simple base type to describe
8779 the range type instead of the range's actual base type,
8780 expecting us to get the real base type from the encoding
8781 anyway. In this situation, the encoding cannot be ignored
8782 as redundant. */
8783 return 0;
8784 }
8785
8908fca5
JB
8786 if (is_dynamic_type (range_type))
8787 return 0;
8788
8789 if (TYPE_NAME (encoding_type) == NULL)
8790 return 0;
8791
8792 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8793 if (bounds_str == NULL)
8794 return 0;
8795
8796 n = 8; /* Skip "___XDLU_". */
8797 if (!ada_scan_number (bounds_str, n, &lo, &n))
8798 return 0;
8799 if (TYPE_LOW_BOUND (range_type) != lo)
8800 return 0;
8801
8802 n += 2; /* Skip the "__" separator between the two bounds. */
8803 if (!ada_scan_number (bounds_str, n, &hi, &n))
8804 return 0;
8805 if (TYPE_HIGH_BOUND (range_type) != hi)
8806 return 0;
8807
8808 return 1;
8809}
8810
8811/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8812 a type following the GNAT encoding for describing array type
8813 indices, only carries redundant information. */
8814
8815static int
8816ada_is_redundant_index_type_desc (struct type *array_type,
8817 struct type *desc_type)
8818{
8819 struct type *this_layer = check_typedef (array_type);
8820 int i;
8821
8822 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8823 {
8824 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8825 TYPE_FIELD_TYPE (desc_type, i)))
8826 return 0;
8827 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8828 }
8829
8830 return 1;
8831}
8832
14f9c5c9
AS
8833/* Assuming that TYPE0 is an array type describing the type of a value
8834 at ADDR, and that DVAL describes a record containing any
8835 discriminants used in TYPE0, returns a type for the value that
8836 contains no dynamic components (that is, no components whose sizes
8837 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8838 true, gives an error message if the resulting type's size is over
4c4b4cd2 8839 varsize_limit. */
14f9c5c9 8840
d2e4a39e
AS
8841static struct type *
8842to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8843 int ignore_too_big)
14f9c5c9 8844{
d2e4a39e
AS
8845 struct type *index_type_desc;
8846 struct type *result;
ad82864c 8847 int constrained_packed_array_p;
931e5bc3 8848 static const char *xa_suffix = "___XA";
14f9c5c9 8849
b0dd7688 8850 type0 = ada_check_typedef (type0);
284614f0 8851 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8852 return type0;
14f9c5c9 8853
ad82864c
JB
8854 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8855 if (constrained_packed_array_p)
8856 type0 = decode_constrained_packed_array_type (type0);
284614f0 8857
931e5bc3
JG
8858 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8859
8860 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8861 encoding suffixed with 'P' may still be generated. If so,
8862 it should be used to find the XA type. */
8863
8864 if (index_type_desc == NULL)
8865 {
1da0522e 8866 const char *type_name = ada_type_name (type0);
931e5bc3 8867
1da0522e 8868 if (type_name != NULL)
931e5bc3 8869 {
1da0522e 8870 const int len = strlen (type_name);
931e5bc3
JG
8871 char *name = (char *) alloca (len + strlen (xa_suffix));
8872
1da0522e 8873 if (type_name[len - 1] == 'P')
931e5bc3 8874 {
1da0522e 8875 strcpy (name, type_name);
931e5bc3
JG
8876 strcpy (name + len - 1, xa_suffix);
8877 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8878 }
8879 }
8880 }
8881
28c85d6c 8882 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8883 if (index_type_desc != NULL
8884 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8885 {
8886 /* Ignore this ___XA parallel type, as it does not bring any
8887 useful information. This allows us to avoid creating fixed
8888 versions of the array's index types, which would be identical
8889 to the original ones. This, in turn, can also help avoid
8890 the creation of fixed versions of the array itself. */
8891 index_type_desc = NULL;
8892 }
8893
14f9c5c9
AS
8894 if (index_type_desc == NULL)
8895 {
61ee279c 8896 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8897
14f9c5c9 8898 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8899 depend on the contents of the array in properly constructed
8900 debugging data. */
529cad9c
PH
8901 /* Create a fixed version of the array element type.
8902 We're not providing the address of an element here,
e1d5a0d2 8903 and thus the actual object value cannot be inspected to do
529cad9c
PH
8904 the conversion. This should not be a problem, since arrays of
8905 unconstrained objects are not allowed. In particular, all
8906 the elements of an array of a tagged type should all be of
8907 the same type specified in the debugging info. No need to
8908 consult the object tag. */
1ed6ede0 8909 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8910
284614f0
JB
8911 /* Make sure we always create a new array type when dealing with
8912 packed array types, since we're going to fix-up the array
8913 type length and element bitsize a little further down. */
ad82864c 8914 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8915 result = type0;
14f9c5c9 8916 else
e9bb382b 8917 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8918 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8919 }
8920 else
8921 {
8922 int i;
8923 struct type *elt_type0;
8924
8925 elt_type0 = type0;
8926 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8927 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8928
8929 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8930 depend on the contents of the array in properly constructed
8931 debugging data. */
529cad9c
PH
8932 /* Create a fixed version of the array element type.
8933 We're not providing the address of an element here,
e1d5a0d2 8934 and thus the actual object value cannot be inspected to do
529cad9c
PH
8935 the conversion. This should not be a problem, since arrays of
8936 unconstrained objects are not allowed. In particular, all
8937 the elements of an array of a tagged type should all be of
8938 the same type specified in the debugging info. No need to
8939 consult the object tag. */
1ed6ede0
JB
8940 result =
8941 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8942
8943 elt_type0 = type0;
14f9c5c9 8944 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8945 {
8946 struct type *range_type =
28c85d6c 8947 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8948
e9bb382b 8949 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8950 result, range_type);
1ce677a4 8951 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8952 }
d2e4a39e 8953 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8954 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8955 }
8956
2e6fda7d
JB
8957 /* We want to preserve the type name. This can be useful when
8958 trying to get the type name of a value that has already been
8959 printed (for instance, if the user did "print VAR; whatis $". */
8960 TYPE_NAME (result) = TYPE_NAME (type0);
8961
ad82864c 8962 if (constrained_packed_array_p)
284614f0
JB
8963 {
8964 /* So far, the resulting type has been created as if the original
8965 type was a regular (non-packed) array type. As a result, the
8966 bitsize of the array elements needs to be set again, and the array
8967 length needs to be recomputed based on that bitsize. */
8968 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8969 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8970
8971 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8972 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8973 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8974 TYPE_LENGTH (result)++;
8975 }
8976
876cecd0 8977 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8978 return result;
d2e4a39e 8979}
14f9c5c9
AS
8980
8981
8982/* A standard type (containing no dynamically sized components)
8983 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8984 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8985 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8986 ADDRESS or in VALADDR contains these discriminants.
8987
1ed6ede0
JB
8988 If CHECK_TAG is not null, in the case of tagged types, this function
8989 attempts to locate the object's tag and use it to compute the actual
8990 type. However, when ADDRESS is null, we cannot use it to determine the
8991 location of the tag, and therefore compute the tagged type's actual type.
8992 So we return the tagged type without consulting the tag. */
529cad9c 8993
f192137b
JB
8994static struct type *
8995ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8996 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8997{
61ee279c 8998 type = ada_check_typedef (type);
d2e4a39e
AS
8999 switch (TYPE_CODE (type))
9000 {
9001 default:
14f9c5c9 9002 return type;
d2e4a39e 9003 case TYPE_CODE_STRUCT:
4c4b4cd2 9004 {
76a01679 9005 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
9006 struct type *fixed_record_type =
9007 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 9008
529cad9c
PH
9009 /* If STATIC_TYPE is a tagged type and we know the object's address,
9010 then we can determine its tag, and compute the object's actual
0963b4bd 9011 type from there. Note that we have to use the fixed record
1ed6ede0
JB
9012 type (the parent part of the record may have dynamic fields
9013 and the way the location of _tag is expressed may depend on
9014 them). */
529cad9c 9015
1ed6ede0 9016 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 9017 {
b50d69b5
JG
9018 struct value *tag =
9019 value_tag_from_contents_and_address
9020 (fixed_record_type,
9021 valaddr,
9022 address);
9023 struct type *real_type = type_from_tag (tag);
9024 struct value *obj =
9025 value_from_contents_and_address (fixed_record_type,
9026 valaddr,
9027 address);
9f1f738a 9028 fixed_record_type = value_type (obj);
76a01679 9029 if (real_type != NULL)
b50d69b5
JG
9030 return to_fixed_record_type
9031 (real_type, NULL,
9032 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 9033 }
4af88198
JB
9034
9035 /* Check to see if there is a parallel ___XVZ variable.
9036 If there is, then it provides the actual size of our type. */
9037 else if (ada_type_name (fixed_record_type) != NULL)
9038 {
0d5cff50 9039 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
9040 char *xvz_name
9041 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 9042 bool xvz_found = false;
4af88198
JB
9043 LONGEST size;
9044
88c15c34 9045 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
eccab96d
JB
9046 TRY
9047 {
9048 xvz_found = get_int_var_value (xvz_name, size);
9049 }
9050 CATCH (except, RETURN_MASK_ERROR)
9051 {
9052 /* We found the variable, but somehow failed to read
9053 its value. Rethrow the same error, but with a little
9054 bit more information, to help the user understand
9055 what went wrong (Eg: the variable might have been
9056 optimized out). */
9057 throw_error (except.error,
9058 _("unable to read value of %s (%s)"),
9059 xvz_name, except.message);
9060 }
9061 END_CATCH
9062
9063 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
9064 {
9065 fixed_record_type = copy_type (fixed_record_type);
9066 TYPE_LENGTH (fixed_record_type) = size;
9067
9068 /* The FIXED_RECORD_TYPE may have be a stub. We have
9069 observed this when the debugging info is STABS, and
9070 apparently it is something that is hard to fix.
9071
9072 In practice, we don't need the actual type definition
9073 at all, because the presence of the XVZ variable allows us
9074 to assume that there must be a XVS type as well, which we
9075 should be able to use later, when we need the actual type
9076 definition.
9077
9078 In the meantime, pretend that the "fixed" type we are
9079 returning is NOT a stub, because this can cause trouble
9080 when using this type to create new types targeting it.
9081 Indeed, the associated creation routines often check
9082 whether the target type is a stub and will try to replace
0963b4bd 9083 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9084 might cause the new type to have the wrong size too.
9085 Consider the case of an array, for instance, where the size
9086 of the array is computed from the number of elements in
9087 our array multiplied by the size of its element. */
9088 TYPE_STUB (fixed_record_type) = 0;
9089 }
9090 }
1ed6ede0 9091 return fixed_record_type;
4c4b4cd2 9092 }
d2e4a39e 9093 case TYPE_CODE_ARRAY:
4c4b4cd2 9094 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9095 case TYPE_CODE_UNION:
9096 if (dval == NULL)
4c4b4cd2 9097 return type;
d2e4a39e 9098 else
4c4b4cd2 9099 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9100 }
14f9c5c9
AS
9101}
9102
f192137b
JB
9103/* The same as ada_to_fixed_type_1, except that it preserves the type
9104 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9105
9106 The typedef layer needs be preserved in order to differentiate between
9107 arrays and array pointers when both types are implemented using the same
9108 fat pointer. In the array pointer case, the pointer is encoded as
9109 a typedef of the pointer type. For instance, considering:
9110
9111 type String_Access is access String;
9112 S1 : String_Access := null;
9113
9114 To the debugger, S1 is defined as a typedef of type String. But
9115 to the user, it is a pointer. So if the user tries to print S1,
9116 we should not dereference the array, but print the array address
9117 instead.
9118
9119 If we didn't preserve the typedef layer, we would lose the fact that
9120 the type is to be presented as a pointer (needs de-reference before
9121 being printed). And we would also use the source-level type name. */
f192137b
JB
9122
9123struct type *
9124ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9125 CORE_ADDR address, struct value *dval, int check_tag)
9126
9127{
9128 struct type *fixed_type =
9129 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9130
96dbd2c1
JB
9131 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9132 then preserve the typedef layer.
9133
9134 Implementation note: We can only check the main-type portion of
9135 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9136 from TYPE now returns a type that has the same instance flags
9137 as TYPE. For instance, if TYPE is a "typedef const", and its
9138 target type is a "struct", then the typedef elimination will return
9139 a "const" version of the target type. See check_typedef for more
9140 details about how the typedef layer elimination is done.
9141
9142 brobecker/2010-11-19: It seems to me that the only case where it is
9143 useful to preserve the typedef layer is when dealing with fat pointers.
9144 Perhaps, we could add a check for that and preserve the typedef layer
9145 only in that situation. But this seems unecessary so far, probably
9146 because we call check_typedef/ada_check_typedef pretty much everywhere.
9147 */
f192137b 9148 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9149 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9150 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9151 return type;
9152
9153 return fixed_type;
9154}
9155
14f9c5c9 9156/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9157 TYPE0, but based on no runtime data. */
14f9c5c9 9158
d2e4a39e
AS
9159static struct type *
9160to_static_fixed_type (struct type *type0)
14f9c5c9 9161{
d2e4a39e 9162 struct type *type;
14f9c5c9
AS
9163
9164 if (type0 == NULL)
9165 return NULL;
9166
876cecd0 9167 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9168 return type0;
9169
61ee279c 9170 type0 = ada_check_typedef (type0);
d2e4a39e 9171
14f9c5c9
AS
9172 switch (TYPE_CODE (type0))
9173 {
9174 default:
9175 return type0;
9176 case TYPE_CODE_STRUCT:
9177 type = dynamic_template_type (type0);
d2e4a39e 9178 if (type != NULL)
4c4b4cd2
PH
9179 return template_to_static_fixed_type (type);
9180 else
9181 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9182 case TYPE_CODE_UNION:
9183 type = ada_find_parallel_type (type0, "___XVU");
9184 if (type != NULL)
4c4b4cd2
PH
9185 return template_to_static_fixed_type (type);
9186 else
9187 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9188 }
9189}
9190
4c4b4cd2
PH
9191/* A static approximation of TYPE with all type wrappers removed. */
9192
d2e4a39e
AS
9193static struct type *
9194static_unwrap_type (struct type *type)
14f9c5c9
AS
9195{
9196 if (ada_is_aligner_type (type))
9197 {
61ee279c 9198 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9199 if (ada_type_name (type1) == NULL)
4c4b4cd2 9200 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9201
9202 return static_unwrap_type (type1);
9203 }
d2e4a39e 9204 else
14f9c5c9 9205 {
d2e4a39e 9206 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9207
d2e4a39e 9208 if (raw_real_type == type)
4c4b4cd2 9209 return type;
14f9c5c9 9210 else
4c4b4cd2 9211 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9212 }
9213}
9214
9215/* In some cases, incomplete and private types require
4c4b4cd2 9216 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9217 type Foo;
9218 type FooP is access Foo;
9219 V: FooP;
9220 type Foo is array ...;
4c4b4cd2 9221 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9222 cross-references to such types, we instead substitute for FooP a
9223 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9224 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9225
9226/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9227 exists, otherwise TYPE. */
9228
d2e4a39e 9229struct type *
61ee279c 9230ada_check_typedef (struct type *type)
14f9c5c9 9231{
727e3d2e
JB
9232 if (type == NULL)
9233 return NULL;
9234
736ade86
XR
9235 /* If our type is an access to an unconstrained array, which is encoded
9236 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
720d1a40
JB
9237 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9238 what allows us to distinguish between fat pointers that represent
9239 array types, and fat pointers that represent array access types
9240 (in both cases, the compiler implements them as fat pointers). */
736ade86 9241 if (ada_is_access_to_unconstrained_array (type))
720d1a40
JB
9242 return type;
9243
f168693b 9244 type = check_typedef (type);
14f9c5c9 9245 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9246 || !TYPE_STUB (type)
e86ca25f 9247 || TYPE_NAME (type) == NULL)
14f9c5c9 9248 return type;
d2e4a39e 9249 else
14f9c5c9 9250 {
e86ca25f 9251 const char *name = TYPE_NAME (type);
d2e4a39e 9252 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9253
05e522ef
JB
9254 if (type1 == NULL)
9255 return type;
9256
9257 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9258 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9259 types, only for the typedef-to-array types). If that's the case,
9260 strip the typedef layer. */
9261 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9262 type1 = ada_check_typedef (type1);
9263
9264 return type1;
14f9c5c9
AS
9265 }
9266}
9267
9268/* A value representing the data at VALADDR/ADDRESS as described by
9269 type TYPE0, but with a standard (static-sized) type that correctly
9270 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9271 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9272 creation of struct values]. */
14f9c5c9 9273
4c4b4cd2
PH
9274static struct value *
9275ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9276 struct value *val0)
14f9c5c9 9277{
1ed6ede0 9278 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9279
14f9c5c9
AS
9280 if (type == type0 && val0 != NULL)
9281 return val0;
cc0e770c
JB
9282
9283 if (VALUE_LVAL (val0) != lval_memory)
9284 {
9285 /* Our value does not live in memory; it could be a convenience
9286 variable, for instance. Create a not_lval value using val0's
9287 contents. */
9288 return value_from_contents (type, value_contents (val0));
9289 }
9290
9291 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9292}
9293
9294/* A value representing VAL, but with a standard (static-sized) type
9295 that correctly describes it. Does not necessarily create a new
9296 value. */
9297
0c3acc09 9298struct value *
4c4b4cd2
PH
9299ada_to_fixed_value (struct value *val)
9300{
c48db5ca 9301 val = unwrap_value (val);
d8ce9127 9302 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
c48db5ca 9303 return val;
14f9c5c9 9304}
d2e4a39e 9305\f
14f9c5c9 9306
14f9c5c9
AS
9307/* Attributes */
9308
4c4b4cd2
PH
9309/* Table mapping attribute numbers to names.
9310 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9311
d2e4a39e 9312static const char *attribute_names[] = {
14f9c5c9
AS
9313 "<?>",
9314
d2e4a39e 9315 "first",
14f9c5c9
AS
9316 "last",
9317 "length",
9318 "image",
14f9c5c9
AS
9319 "max",
9320 "min",
4c4b4cd2
PH
9321 "modulus",
9322 "pos",
9323 "size",
9324 "tag",
14f9c5c9 9325 "val",
14f9c5c9
AS
9326 0
9327};
9328
d2e4a39e 9329const char *
4c4b4cd2 9330ada_attribute_name (enum exp_opcode n)
14f9c5c9 9331{
4c4b4cd2
PH
9332 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9333 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9334 else
9335 return attribute_names[0];
9336}
9337
4c4b4cd2 9338/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9339
4c4b4cd2
PH
9340static LONGEST
9341pos_atr (struct value *arg)
14f9c5c9 9342{
24209737
PH
9343 struct value *val = coerce_ref (arg);
9344 struct type *type = value_type (val);
aa715135 9345 LONGEST result;
14f9c5c9 9346
d2e4a39e 9347 if (!discrete_type_p (type))
323e0a4a 9348 error (_("'POS only defined on discrete types"));
14f9c5c9 9349
aa715135
JG
9350 if (!discrete_position (type, value_as_long (val), &result))
9351 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9352
aa715135 9353 return result;
4c4b4cd2
PH
9354}
9355
9356static struct value *
3cb382c9 9357value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9358{
3cb382c9 9359 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9360}
9361
4c4b4cd2 9362/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9363
d2e4a39e
AS
9364static struct value *
9365value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9366{
d2e4a39e 9367 if (!discrete_type_p (type))
323e0a4a 9368 error (_("'VAL only defined on discrete types"));
df407dfe 9369 if (!integer_type_p (value_type (arg)))
323e0a4a 9370 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9371
9372 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9373 {
9374 long pos = value_as_long (arg);
5b4ee69b 9375
14f9c5c9 9376 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9377 error (_("argument to 'VAL out of range"));
14e75d8e 9378 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9379 }
9380 else
9381 return value_from_longest (type, value_as_long (arg));
9382}
14f9c5c9 9383\f
d2e4a39e 9384
4c4b4cd2 9385 /* Evaluation */
14f9c5c9 9386
4c4b4cd2
PH
9387/* True if TYPE appears to be an Ada character type.
9388 [At the moment, this is true only for Character and Wide_Character;
9389 It is a heuristic test that could stand improvement]. */
14f9c5c9 9390
d2e4a39e
AS
9391int
9392ada_is_character_type (struct type *type)
14f9c5c9 9393{
7b9f71f2
JB
9394 const char *name;
9395
9396 /* If the type code says it's a character, then assume it really is,
9397 and don't check any further. */
9398 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9399 return 1;
9400
9401 /* Otherwise, assume it's a character type iff it is a discrete type
9402 with a known character type name. */
9403 name = ada_type_name (type);
9404 return (name != NULL
9405 && (TYPE_CODE (type) == TYPE_CODE_INT
9406 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9407 && (strcmp (name, "character") == 0
9408 || strcmp (name, "wide_character") == 0
5a517ebd 9409 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9410 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9411}
9412
4c4b4cd2 9413/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9414
9415int
ebf56fd3 9416ada_is_string_type (struct type *type)
14f9c5c9 9417{
61ee279c 9418 type = ada_check_typedef (type);
d2e4a39e 9419 if (type != NULL
14f9c5c9 9420 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9421 && (ada_is_simple_array_type (type)
9422 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9423 && ada_array_arity (type) == 1)
9424 {
9425 struct type *elttype = ada_array_element_type (type, 1);
9426
9427 return ada_is_character_type (elttype);
9428 }
d2e4a39e 9429 else
14f9c5c9
AS
9430 return 0;
9431}
9432
5bf03f13
JB
9433/* The compiler sometimes provides a parallel XVS type for a given
9434 PAD type. Normally, it is safe to follow the PAD type directly,
9435 but older versions of the compiler have a bug that causes the offset
9436 of its "F" field to be wrong. Following that field in that case
9437 would lead to incorrect results, but this can be worked around
9438 by ignoring the PAD type and using the associated XVS type instead.
9439
9440 Set to True if the debugger should trust the contents of PAD types.
9441 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9442static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9443
9444/* True if TYPE is a struct type introduced by the compiler to force the
9445 alignment of a value. Such types have a single field with a
4c4b4cd2 9446 distinctive name. */
14f9c5c9
AS
9447
9448int
ebf56fd3 9449ada_is_aligner_type (struct type *type)
14f9c5c9 9450{
61ee279c 9451 type = ada_check_typedef (type);
714e53ab 9452
5bf03f13 9453 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9454 return 0;
9455
14f9c5c9 9456 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9457 && TYPE_NFIELDS (type) == 1
9458 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9459}
9460
9461/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9462 the parallel type. */
14f9c5c9 9463
d2e4a39e
AS
9464struct type *
9465ada_get_base_type (struct type *raw_type)
14f9c5c9 9466{
d2e4a39e
AS
9467 struct type *real_type_namer;
9468 struct type *raw_real_type;
14f9c5c9
AS
9469
9470 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9471 return raw_type;
9472
284614f0
JB
9473 if (ada_is_aligner_type (raw_type))
9474 /* The encoding specifies that we should always use the aligner type.
9475 So, even if this aligner type has an associated XVS type, we should
9476 simply ignore it.
9477
9478 According to the compiler gurus, an XVS type parallel to an aligner
9479 type may exist because of a stabs limitation. In stabs, aligner
9480 types are empty because the field has a variable-sized type, and
9481 thus cannot actually be used as an aligner type. As a result,
9482 we need the associated parallel XVS type to decode the type.
9483 Since the policy in the compiler is to not change the internal
9484 representation based on the debugging info format, we sometimes
9485 end up having a redundant XVS type parallel to the aligner type. */
9486 return raw_type;
9487
14f9c5c9 9488 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9489 if (real_type_namer == NULL
14f9c5c9
AS
9490 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9491 || TYPE_NFIELDS (real_type_namer) != 1)
9492 return raw_type;
9493
f80d3ff2
JB
9494 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9495 {
9496 /* This is an older encoding form where the base type needs to be
9497 looked up by name. We prefer the newer enconding because it is
9498 more efficient. */
9499 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9500 if (raw_real_type == NULL)
9501 return raw_type;
9502 else
9503 return raw_real_type;
9504 }
9505
9506 /* The field in our XVS type is a reference to the base type. */
9507 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9508}
14f9c5c9 9509
4c4b4cd2 9510/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9511
d2e4a39e
AS
9512struct type *
9513ada_aligned_type (struct type *type)
14f9c5c9
AS
9514{
9515 if (ada_is_aligner_type (type))
9516 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9517 else
9518 return ada_get_base_type (type);
9519}
9520
9521
9522/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9523 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9524
fc1a4b47
AC
9525const gdb_byte *
9526ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9527{
d2e4a39e 9528 if (ada_is_aligner_type (type))
14f9c5c9 9529 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9530 valaddr +
9531 TYPE_FIELD_BITPOS (type,
9532 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9533 else
9534 return valaddr;
9535}
9536
4c4b4cd2
PH
9537
9538
14f9c5c9 9539/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9540 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9541const char *
9542ada_enum_name (const char *name)
14f9c5c9 9543{
4c4b4cd2
PH
9544 static char *result;
9545 static size_t result_len = 0;
e6a959d6 9546 const char *tmp;
14f9c5c9 9547
4c4b4cd2
PH
9548 /* First, unqualify the enumeration name:
9549 1. Search for the last '.' character. If we find one, then skip
177b42fe 9550 all the preceding characters, the unqualified name starts
76a01679 9551 right after that dot.
4c4b4cd2 9552 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9553 translates dots into "__". Search forward for double underscores,
9554 but stop searching when we hit an overloading suffix, which is
9555 of the form "__" followed by digits. */
4c4b4cd2 9556
c3e5cd34
PH
9557 tmp = strrchr (name, '.');
9558 if (tmp != NULL)
4c4b4cd2
PH
9559 name = tmp + 1;
9560 else
14f9c5c9 9561 {
4c4b4cd2
PH
9562 while ((tmp = strstr (name, "__")) != NULL)
9563 {
9564 if (isdigit (tmp[2]))
9565 break;
9566 else
9567 name = tmp + 2;
9568 }
14f9c5c9
AS
9569 }
9570
9571 if (name[0] == 'Q')
9572 {
14f9c5c9 9573 int v;
5b4ee69b 9574
14f9c5c9 9575 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9576 {
9577 if (sscanf (name + 2, "%x", &v) != 1)
9578 return name;
9579 }
14f9c5c9 9580 else
4c4b4cd2 9581 return name;
14f9c5c9 9582
4c4b4cd2 9583 GROW_VECT (result, result_len, 16);
14f9c5c9 9584 if (isascii (v) && isprint (v))
88c15c34 9585 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9586 else if (name[1] == 'U')
88c15c34 9587 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9588 else
88c15c34 9589 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9590
9591 return result;
9592 }
d2e4a39e 9593 else
4c4b4cd2 9594 {
c3e5cd34
PH
9595 tmp = strstr (name, "__");
9596 if (tmp == NULL)
9597 tmp = strstr (name, "$");
9598 if (tmp != NULL)
4c4b4cd2
PH
9599 {
9600 GROW_VECT (result, result_len, tmp - name + 1);
9601 strncpy (result, name, tmp - name);
9602 result[tmp - name] = '\0';
9603 return result;
9604 }
9605
9606 return name;
9607 }
14f9c5c9
AS
9608}
9609
14f9c5c9
AS
9610/* Evaluate the subexpression of EXP starting at *POS as for
9611 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9612 expression. */
14f9c5c9 9613
d2e4a39e
AS
9614static struct value *
9615evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9616{
4b27a620 9617 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9618}
9619
9620/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9621 value it wraps. */
14f9c5c9 9622
d2e4a39e
AS
9623static struct value *
9624unwrap_value (struct value *val)
14f9c5c9 9625{
df407dfe 9626 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9627
14f9c5c9
AS
9628 if (ada_is_aligner_type (type))
9629 {
de4d072f 9630 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9631 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9632
14f9c5c9 9633 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9634 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9635
9636 return unwrap_value (v);
9637 }
d2e4a39e 9638 else
14f9c5c9 9639 {
d2e4a39e 9640 struct type *raw_real_type =
61ee279c 9641 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9642
5bf03f13
JB
9643 /* If there is no parallel XVS or XVE type, then the value is
9644 already unwrapped. Return it without further modification. */
9645 if ((type == raw_real_type)
9646 && ada_find_parallel_type (type, "___XVE") == NULL)
9647 return val;
14f9c5c9 9648
d2e4a39e 9649 return
4c4b4cd2
PH
9650 coerce_unspec_val_to_type
9651 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9652 value_address (val),
1ed6ede0 9653 NULL, 1));
14f9c5c9
AS
9654 }
9655}
d2e4a39e
AS
9656
9657static struct value *
50eff16b 9658cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9659{
50eff16b
UW
9660 struct value *scale = ada_scaling_factor (value_type (arg));
9661 arg = value_cast (value_type (scale), arg);
14f9c5c9 9662
50eff16b
UW
9663 arg = value_binop (arg, scale, BINOP_MUL);
9664 return value_cast (type, arg);
14f9c5c9
AS
9665}
9666
d2e4a39e 9667static struct value *
50eff16b 9668cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9669{
50eff16b
UW
9670 if (type == value_type (arg))
9671 return arg;
5b4ee69b 9672
50eff16b
UW
9673 struct value *scale = ada_scaling_factor (type);
9674 if (ada_is_fixed_point_type (value_type (arg)))
9675 arg = cast_from_fixed (value_type (scale), arg);
9676 else
9677 arg = value_cast (value_type (scale), arg);
9678
9679 arg = value_binop (arg, scale, BINOP_DIV);
9680 return value_cast (type, arg);
14f9c5c9
AS
9681}
9682
d99dcf51
JB
9683/* Given two array types T1 and T2, return nonzero iff both arrays
9684 contain the same number of elements. */
9685
9686static int
9687ada_same_array_size_p (struct type *t1, struct type *t2)
9688{
9689 LONGEST lo1, hi1, lo2, hi2;
9690
9691 /* Get the array bounds in order to verify that the size of
9692 the two arrays match. */
9693 if (!get_array_bounds (t1, &lo1, &hi1)
9694 || !get_array_bounds (t2, &lo2, &hi2))
9695 error (_("unable to determine array bounds"));
9696
9697 /* To make things easier for size comparison, normalize a bit
9698 the case of empty arrays by making sure that the difference
9699 between upper bound and lower bound is always -1. */
9700 if (lo1 > hi1)
9701 hi1 = lo1 - 1;
9702 if (lo2 > hi2)
9703 hi2 = lo2 - 1;
9704
9705 return (hi1 - lo1 == hi2 - lo2);
9706}
9707
9708/* Assuming that VAL is an array of integrals, and TYPE represents
9709 an array with the same number of elements, but with wider integral
9710 elements, return an array "casted" to TYPE. In practice, this
9711 means that the returned array is built by casting each element
9712 of the original array into TYPE's (wider) element type. */
9713
9714static struct value *
9715ada_promote_array_of_integrals (struct type *type, struct value *val)
9716{
9717 struct type *elt_type = TYPE_TARGET_TYPE (type);
9718 LONGEST lo, hi;
9719 struct value *res;
9720 LONGEST i;
9721
9722 /* Verify that both val and type are arrays of scalars, and
9723 that the size of val's elements is smaller than the size
9724 of type's element. */
9725 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9726 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9727 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9728 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9729 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9730 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9731
9732 if (!get_array_bounds (type, &lo, &hi))
9733 error (_("unable to determine array bounds"));
9734
9735 res = allocate_value (type);
9736
9737 /* Promote each array element. */
9738 for (i = 0; i < hi - lo + 1; i++)
9739 {
9740 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9741
9742 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9743 value_contents_all (elt), TYPE_LENGTH (elt_type));
9744 }
9745
9746 return res;
9747}
9748
4c4b4cd2
PH
9749/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9750 return the converted value. */
9751
d2e4a39e
AS
9752static struct value *
9753coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9754{
df407dfe 9755 struct type *type2 = value_type (val);
5b4ee69b 9756
14f9c5c9
AS
9757 if (type == type2)
9758 return val;
9759
61ee279c
PH
9760 type2 = ada_check_typedef (type2);
9761 type = ada_check_typedef (type);
14f9c5c9 9762
d2e4a39e
AS
9763 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9764 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9765 {
9766 val = ada_value_ind (val);
df407dfe 9767 type2 = value_type (val);
14f9c5c9
AS
9768 }
9769
d2e4a39e 9770 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9771 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9772 {
d99dcf51
JB
9773 if (!ada_same_array_size_p (type, type2))
9774 error (_("cannot assign arrays of different length"));
9775
9776 if (is_integral_type (TYPE_TARGET_TYPE (type))
9777 && is_integral_type (TYPE_TARGET_TYPE (type2))
9778 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9779 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9780 {
9781 /* Allow implicit promotion of the array elements to
9782 a wider type. */
9783 return ada_promote_array_of_integrals (type, val);
9784 }
9785
9786 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9787 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9788 error (_("Incompatible types in assignment"));
04624583 9789 deprecated_set_value_type (val, type);
14f9c5c9 9790 }
d2e4a39e 9791 return val;
14f9c5c9
AS
9792}
9793
4c4b4cd2
PH
9794static struct value *
9795ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9796{
9797 struct value *val;
9798 struct type *type1, *type2;
9799 LONGEST v, v1, v2;
9800
994b9211
AC
9801 arg1 = coerce_ref (arg1);
9802 arg2 = coerce_ref (arg2);
18af8284
JB
9803 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9804 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9805
76a01679
JB
9806 if (TYPE_CODE (type1) != TYPE_CODE_INT
9807 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9808 return value_binop (arg1, arg2, op);
9809
76a01679 9810 switch (op)
4c4b4cd2
PH
9811 {
9812 case BINOP_MOD:
9813 case BINOP_DIV:
9814 case BINOP_REM:
9815 break;
9816 default:
9817 return value_binop (arg1, arg2, op);
9818 }
9819
9820 v2 = value_as_long (arg2);
9821 if (v2 == 0)
323e0a4a 9822 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9823
9824 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9825 return value_binop (arg1, arg2, op);
9826
9827 v1 = value_as_long (arg1);
9828 switch (op)
9829 {
9830 case BINOP_DIV:
9831 v = v1 / v2;
76a01679
JB
9832 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9833 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9834 break;
9835 case BINOP_REM:
9836 v = v1 % v2;
76a01679
JB
9837 if (v * v1 < 0)
9838 v -= v2;
4c4b4cd2
PH
9839 break;
9840 default:
9841 /* Should not reach this point. */
9842 v = 0;
9843 }
9844
9845 val = allocate_value (type1);
990a07ab 9846 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9847 TYPE_LENGTH (value_type (val)),
9848 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9849 return val;
9850}
9851
9852static int
9853ada_value_equal (struct value *arg1, struct value *arg2)
9854{
df407dfe
AC
9855 if (ada_is_direct_array_type (value_type (arg1))
9856 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9857 {
79e8fcaa
JB
9858 struct type *arg1_type, *arg2_type;
9859
f58b38bf
JB
9860 /* Automatically dereference any array reference before
9861 we attempt to perform the comparison. */
9862 arg1 = ada_coerce_ref (arg1);
9863 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9864
4c4b4cd2
PH
9865 arg1 = ada_coerce_to_simple_array (arg1);
9866 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9867
9868 arg1_type = ada_check_typedef (value_type (arg1));
9869 arg2_type = ada_check_typedef (value_type (arg2));
9870
9871 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9872 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9873 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9874 /* FIXME: The following works only for types whose
76a01679
JB
9875 representations use all bits (no padding or undefined bits)
9876 and do not have user-defined equality. */
79e8fcaa
JB
9877 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9878 && memcmp (value_contents (arg1), value_contents (arg2),
9879 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9880 }
9881 return value_equal (arg1, arg2);
9882}
9883
52ce6436
PH
9884/* Total number of component associations in the aggregate starting at
9885 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9886 OP_AGGREGATE. */
52ce6436
PH
9887
9888static int
9889num_component_specs (struct expression *exp, int pc)
9890{
9891 int n, m, i;
5b4ee69b 9892
52ce6436
PH
9893 m = exp->elts[pc + 1].longconst;
9894 pc += 3;
9895 n = 0;
9896 for (i = 0; i < m; i += 1)
9897 {
9898 switch (exp->elts[pc].opcode)
9899 {
9900 default:
9901 n += 1;
9902 break;
9903 case OP_CHOICES:
9904 n += exp->elts[pc + 1].longconst;
9905 break;
9906 }
9907 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9908 }
9909 return n;
9910}
9911
9912/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9913 component of LHS (a simple array or a record), updating *POS past
9914 the expression, assuming that LHS is contained in CONTAINER. Does
9915 not modify the inferior's memory, nor does it modify LHS (unless
9916 LHS == CONTAINER). */
9917
9918static void
9919assign_component (struct value *container, struct value *lhs, LONGEST index,
9920 struct expression *exp, int *pos)
9921{
9922 struct value *mark = value_mark ();
9923 struct value *elt;
0e2da9f0 9924 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9925
0e2da9f0 9926 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9927 {
22601c15
UW
9928 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9929 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9930
52ce6436
PH
9931 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9932 }
9933 else
9934 {
9935 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9936 elt = ada_to_fixed_value (elt);
52ce6436
PH
9937 }
9938
9939 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9940 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9941 else
9942 value_assign_to_component (container, elt,
9943 ada_evaluate_subexp (NULL, exp, pos,
9944 EVAL_NORMAL));
9945
9946 value_free_to_mark (mark);
9947}
9948
9949/* Assuming that LHS represents an lvalue having a record or array
9950 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9951 of that aggregate's value to LHS, advancing *POS past the
9952 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9953 lvalue containing LHS (possibly LHS itself). Does not modify
9954 the inferior's memory, nor does it modify the contents of
0963b4bd 9955 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9956
9957static struct value *
9958assign_aggregate (struct value *container,
9959 struct value *lhs, struct expression *exp,
9960 int *pos, enum noside noside)
9961{
9962 struct type *lhs_type;
9963 int n = exp->elts[*pos+1].longconst;
9964 LONGEST low_index, high_index;
9965 int num_specs;
9966 LONGEST *indices;
9967 int max_indices, num_indices;
52ce6436 9968 int i;
52ce6436
PH
9969
9970 *pos += 3;
9971 if (noside != EVAL_NORMAL)
9972 {
52ce6436
PH
9973 for (i = 0; i < n; i += 1)
9974 ada_evaluate_subexp (NULL, exp, pos, noside);
9975 return container;
9976 }
9977
9978 container = ada_coerce_ref (container);
9979 if (ada_is_direct_array_type (value_type (container)))
9980 container = ada_coerce_to_simple_array (container);
9981 lhs = ada_coerce_ref (lhs);
9982 if (!deprecated_value_modifiable (lhs))
9983 error (_("Left operand of assignment is not a modifiable lvalue."));
9984
0e2da9f0 9985 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9986 if (ada_is_direct_array_type (lhs_type))
9987 {
9988 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 9989 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9990 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9991 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9992 }
9993 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9994 {
9995 low_index = 0;
9996 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9997 }
9998 else
9999 error (_("Left-hand side must be array or record."));
10000
10001 num_specs = num_component_specs (exp, *pos - 3);
10002 max_indices = 4 * num_specs + 4;
8d749320 10003 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
10004 indices[0] = indices[1] = low_index - 1;
10005 indices[2] = indices[3] = high_index + 1;
10006 num_indices = 4;
10007
10008 for (i = 0; i < n; i += 1)
10009 {
10010 switch (exp->elts[*pos].opcode)
10011 {
1fbf5ada
JB
10012 case OP_CHOICES:
10013 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10014 &num_indices, max_indices,
10015 low_index, high_index);
10016 break;
10017 case OP_POSITIONAL:
10018 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
10019 &num_indices, max_indices,
10020 low_index, high_index);
1fbf5ada
JB
10021 break;
10022 case OP_OTHERS:
10023 if (i != n-1)
10024 error (_("Misplaced 'others' clause"));
10025 aggregate_assign_others (container, lhs, exp, pos, indices,
10026 num_indices, low_index, high_index);
10027 break;
10028 default:
10029 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
10030 }
10031 }
10032
10033 return container;
10034}
10035
10036/* Assign into the component of LHS indexed by the OP_POSITIONAL
10037 construct at *POS, updating *POS past the construct, given that
10038 the positions are relative to lower bound LOW, where HIGH is the
10039 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10040 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 10041 assign_aggregate. */
52ce6436
PH
10042static void
10043aggregate_assign_positional (struct value *container,
10044 struct value *lhs, struct expression *exp,
10045 int *pos, LONGEST *indices, int *num_indices,
10046 int max_indices, LONGEST low, LONGEST high)
10047{
10048 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10049
10050 if (ind - 1 == high)
e1d5a0d2 10051 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
10052 if (ind <= high)
10053 {
10054 add_component_interval (ind, ind, indices, num_indices, max_indices);
10055 *pos += 3;
10056 assign_component (container, lhs, ind, exp, pos);
10057 }
10058 else
10059 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10060}
10061
10062/* Assign into the components of LHS indexed by the OP_CHOICES
10063 construct at *POS, updating *POS past the construct, given that
10064 the allowable indices are LOW..HIGH. Record the indices assigned
10065 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 10066 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10067static void
10068aggregate_assign_from_choices (struct value *container,
10069 struct value *lhs, struct expression *exp,
10070 int *pos, LONGEST *indices, int *num_indices,
10071 int max_indices, LONGEST low, LONGEST high)
10072{
10073 int j;
10074 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10075 int choice_pos, expr_pc;
10076 int is_array = ada_is_direct_array_type (value_type (lhs));
10077
10078 choice_pos = *pos += 3;
10079
10080 for (j = 0; j < n_choices; j += 1)
10081 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10082 expr_pc = *pos;
10083 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10084
10085 for (j = 0; j < n_choices; j += 1)
10086 {
10087 LONGEST lower, upper;
10088 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10089
52ce6436
PH
10090 if (op == OP_DISCRETE_RANGE)
10091 {
10092 choice_pos += 1;
10093 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10094 EVAL_NORMAL));
10095 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10096 EVAL_NORMAL));
10097 }
10098 else if (is_array)
10099 {
10100 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10101 EVAL_NORMAL));
10102 upper = lower;
10103 }
10104 else
10105 {
10106 int ind;
0d5cff50 10107 const char *name;
5b4ee69b 10108
52ce6436
PH
10109 switch (op)
10110 {
10111 case OP_NAME:
10112 name = &exp->elts[choice_pos + 2].string;
10113 break;
10114 case OP_VAR_VALUE:
10115 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10116 break;
10117 default:
10118 error (_("Invalid record component association."));
10119 }
10120 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10121 ind = 0;
10122 if (! find_struct_field (name, value_type (lhs), 0,
10123 NULL, NULL, NULL, NULL, &ind))
10124 error (_("Unknown component name: %s."), name);
10125 lower = upper = ind;
10126 }
10127
10128 if (lower <= upper && (lower < low || upper > high))
10129 error (_("Index in component association out of bounds."));
10130
10131 add_component_interval (lower, upper, indices, num_indices,
10132 max_indices);
10133 while (lower <= upper)
10134 {
10135 int pos1;
5b4ee69b 10136
52ce6436
PH
10137 pos1 = expr_pc;
10138 assign_component (container, lhs, lower, exp, &pos1);
10139 lower += 1;
10140 }
10141 }
10142}
10143
10144/* Assign the value of the expression in the OP_OTHERS construct in
10145 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10146 have not been previously assigned. The index intervals already assigned
10147 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10148 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10149static void
10150aggregate_assign_others (struct value *container,
10151 struct value *lhs, struct expression *exp,
10152 int *pos, LONGEST *indices, int num_indices,
10153 LONGEST low, LONGEST high)
10154{
10155 int i;
5ce64950 10156 int expr_pc = *pos + 1;
52ce6436
PH
10157
10158 for (i = 0; i < num_indices - 2; i += 2)
10159 {
10160 LONGEST ind;
5b4ee69b 10161
52ce6436
PH
10162 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10163 {
5ce64950 10164 int localpos;
5b4ee69b 10165
5ce64950
MS
10166 localpos = expr_pc;
10167 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10168 }
10169 }
10170 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10171}
10172
10173/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10174 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10175 modifying *SIZE as needed. It is an error if *SIZE exceeds
10176 MAX_SIZE. The resulting intervals do not overlap. */
10177static void
10178add_component_interval (LONGEST low, LONGEST high,
10179 LONGEST* indices, int *size, int max_size)
10180{
10181 int i, j;
5b4ee69b 10182
52ce6436
PH
10183 for (i = 0; i < *size; i += 2) {
10184 if (high >= indices[i] && low <= indices[i + 1])
10185 {
10186 int kh;
5b4ee69b 10187
52ce6436
PH
10188 for (kh = i + 2; kh < *size; kh += 2)
10189 if (high < indices[kh])
10190 break;
10191 if (low < indices[i])
10192 indices[i] = low;
10193 indices[i + 1] = indices[kh - 1];
10194 if (high > indices[i + 1])
10195 indices[i + 1] = high;
10196 memcpy (indices + i + 2, indices + kh, *size - kh);
10197 *size -= kh - i - 2;
10198 return;
10199 }
10200 else if (high < indices[i])
10201 break;
10202 }
10203
10204 if (*size == max_size)
10205 error (_("Internal error: miscounted aggregate components."));
10206 *size += 2;
10207 for (j = *size-1; j >= i+2; j -= 1)
10208 indices[j] = indices[j - 2];
10209 indices[i] = low;
10210 indices[i + 1] = high;
10211}
10212
6e48bd2c
JB
10213/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10214 is different. */
10215
10216static struct value *
b7e22850 10217ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10218{
10219 if (type == ada_check_typedef (value_type (arg2)))
10220 return arg2;
10221
10222 if (ada_is_fixed_point_type (type))
95f39a5b 10223 return cast_to_fixed (type, arg2);
6e48bd2c
JB
10224
10225 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10226 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10227
10228 return value_cast (type, arg2);
10229}
10230
284614f0
JB
10231/* Evaluating Ada expressions, and printing their result.
10232 ------------------------------------------------------
10233
21649b50
JB
10234 1. Introduction:
10235 ----------------
10236
284614f0
JB
10237 We usually evaluate an Ada expression in order to print its value.
10238 We also evaluate an expression in order to print its type, which
10239 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10240 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10241 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10242 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10243 similar.
10244
10245 Evaluating expressions is a little more complicated for Ada entities
10246 than it is for entities in languages such as C. The main reason for
10247 this is that Ada provides types whose definition might be dynamic.
10248 One example of such types is variant records. Or another example
10249 would be an array whose bounds can only be known at run time.
10250
10251 The following description is a general guide as to what should be
10252 done (and what should NOT be done) in order to evaluate an expression
10253 involving such types, and when. This does not cover how the semantic
10254 information is encoded by GNAT as this is covered separatly. For the
10255 document used as the reference for the GNAT encoding, see exp_dbug.ads
10256 in the GNAT sources.
10257
10258 Ideally, we should embed each part of this description next to its
10259 associated code. Unfortunately, the amount of code is so vast right
10260 now that it's hard to see whether the code handling a particular
10261 situation might be duplicated or not. One day, when the code is
10262 cleaned up, this guide might become redundant with the comments
10263 inserted in the code, and we might want to remove it.
10264
21649b50
JB
10265 2. ``Fixing'' an Entity, the Simple Case:
10266 -----------------------------------------
10267
284614f0
JB
10268 When evaluating Ada expressions, the tricky issue is that they may
10269 reference entities whose type contents and size are not statically
10270 known. Consider for instance a variant record:
10271
10272 type Rec (Empty : Boolean := True) is record
10273 case Empty is
10274 when True => null;
10275 when False => Value : Integer;
10276 end case;
10277 end record;
10278 Yes : Rec := (Empty => False, Value => 1);
10279 No : Rec := (empty => True);
10280
10281 The size and contents of that record depends on the value of the
10282 descriminant (Rec.Empty). At this point, neither the debugging
10283 information nor the associated type structure in GDB are able to
10284 express such dynamic types. So what the debugger does is to create
10285 "fixed" versions of the type that applies to the specific object.
10286 We also informally refer to this opperation as "fixing" an object,
10287 which means creating its associated fixed type.
10288
10289 Example: when printing the value of variable "Yes" above, its fixed
10290 type would look like this:
10291
10292 type Rec is record
10293 Empty : Boolean;
10294 Value : Integer;
10295 end record;
10296
10297 On the other hand, if we printed the value of "No", its fixed type
10298 would become:
10299
10300 type Rec is record
10301 Empty : Boolean;
10302 end record;
10303
10304 Things become a little more complicated when trying to fix an entity
10305 with a dynamic type that directly contains another dynamic type,
10306 such as an array of variant records, for instance. There are
10307 two possible cases: Arrays, and records.
10308
21649b50
JB
10309 3. ``Fixing'' Arrays:
10310 ---------------------
10311
10312 The type structure in GDB describes an array in terms of its bounds,
10313 and the type of its elements. By design, all elements in the array
10314 have the same type and we cannot represent an array of variant elements
10315 using the current type structure in GDB. When fixing an array,
10316 we cannot fix the array element, as we would potentially need one
10317 fixed type per element of the array. As a result, the best we can do
10318 when fixing an array is to produce an array whose bounds and size
10319 are correct (allowing us to read it from memory), but without having
10320 touched its element type. Fixing each element will be done later,
10321 when (if) necessary.
10322
10323 Arrays are a little simpler to handle than records, because the same
10324 amount of memory is allocated for each element of the array, even if
1b536f04 10325 the amount of space actually used by each element differs from element
21649b50 10326 to element. Consider for instance the following array of type Rec:
284614f0
JB
10327
10328 type Rec_Array is array (1 .. 2) of Rec;
10329
1b536f04
JB
10330 The actual amount of memory occupied by each element might be different
10331 from element to element, depending on the value of their discriminant.
21649b50 10332 But the amount of space reserved for each element in the array remains
1b536f04 10333 fixed regardless. So we simply need to compute that size using
21649b50
JB
10334 the debugging information available, from which we can then determine
10335 the array size (we multiply the number of elements of the array by
10336 the size of each element).
10337
10338 The simplest case is when we have an array of a constrained element
10339 type. For instance, consider the following type declarations:
10340
10341 type Bounded_String (Max_Size : Integer) is
10342 Length : Integer;
10343 Buffer : String (1 .. Max_Size);
10344 end record;
10345 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10346
10347 In this case, the compiler describes the array as an array of
10348 variable-size elements (identified by its XVS suffix) for which
10349 the size can be read in the parallel XVZ variable.
10350
10351 In the case of an array of an unconstrained element type, the compiler
10352 wraps the array element inside a private PAD type. This type should not
10353 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10354 that we also use the adjective "aligner" in our code to designate
10355 these wrapper types.
10356
1b536f04 10357 In some cases, the size allocated for each element is statically
21649b50
JB
10358 known. In that case, the PAD type already has the correct size,
10359 and the array element should remain unfixed.
10360
10361 But there are cases when this size is not statically known.
10362 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10363
10364 type Dynamic is array (1 .. Five) of Integer;
10365 type Wrapper (Has_Length : Boolean := False) is record
10366 Data : Dynamic;
10367 case Has_Length is
10368 when True => Length : Integer;
10369 when False => null;
10370 end case;
10371 end record;
10372 type Wrapper_Array is array (1 .. 2) of Wrapper;
10373
10374 Hello : Wrapper_Array := (others => (Has_Length => True,
10375 Data => (others => 17),
10376 Length => 1));
10377
10378
10379 The debugging info would describe variable Hello as being an
10380 array of a PAD type. The size of that PAD type is not statically
10381 known, but can be determined using a parallel XVZ variable.
10382 In that case, a copy of the PAD type with the correct size should
10383 be used for the fixed array.
10384
21649b50
JB
10385 3. ``Fixing'' record type objects:
10386 ----------------------------------
10387
10388 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10389 record types. In this case, in order to compute the associated
10390 fixed type, we need to determine the size and offset of each of
10391 its components. This, in turn, requires us to compute the fixed
10392 type of each of these components.
10393
10394 Consider for instance the example:
10395
10396 type Bounded_String (Max_Size : Natural) is record
10397 Str : String (1 .. Max_Size);
10398 Length : Natural;
10399 end record;
10400 My_String : Bounded_String (Max_Size => 10);
10401
10402 In that case, the position of field "Length" depends on the size
10403 of field Str, which itself depends on the value of the Max_Size
21649b50 10404 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10405 we need to fix the type of field Str. Therefore, fixing a variant
10406 record requires us to fix each of its components.
10407
10408 However, if a component does not have a dynamic size, the component
10409 should not be fixed. In particular, fields that use a PAD type
10410 should not fixed. Here is an example where this might happen
10411 (assuming type Rec above):
10412
10413 type Container (Big : Boolean) is record
10414 First : Rec;
10415 After : Integer;
10416 case Big is
10417 when True => Another : Integer;
10418 when False => null;
10419 end case;
10420 end record;
10421 My_Container : Container := (Big => False,
10422 First => (Empty => True),
10423 After => 42);
10424
10425 In that example, the compiler creates a PAD type for component First,
10426 whose size is constant, and then positions the component After just
10427 right after it. The offset of component After is therefore constant
10428 in this case.
10429
10430 The debugger computes the position of each field based on an algorithm
10431 that uses, among other things, the actual position and size of the field
21649b50
JB
10432 preceding it. Let's now imagine that the user is trying to print
10433 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10434 end up computing the offset of field After based on the size of the
10435 fixed version of field First. And since in our example First has
10436 only one actual field, the size of the fixed type is actually smaller
10437 than the amount of space allocated to that field, and thus we would
10438 compute the wrong offset of field After.
10439
21649b50
JB
10440 To make things more complicated, we need to watch out for dynamic
10441 components of variant records (identified by the ___XVL suffix in
10442 the component name). Even if the target type is a PAD type, the size
10443 of that type might not be statically known. So the PAD type needs
10444 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10445 we might end up with the wrong size for our component. This can be
10446 observed with the following type declarations:
284614f0
JB
10447
10448 type Octal is new Integer range 0 .. 7;
10449 type Octal_Array is array (Positive range <>) of Octal;
10450 pragma Pack (Octal_Array);
10451
10452 type Octal_Buffer (Size : Positive) is record
10453 Buffer : Octal_Array (1 .. Size);
10454 Length : Integer;
10455 end record;
10456
10457 In that case, Buffer is a PAD type whose size is unset and needs
10458 to be computed by fixing the unwrapped type.
10459
21649b50
JB
10460 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10461 ----------------------------------------------------------
10462
10463 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10464 thus far, be actually fixed?
10465
10466 The answer is: Only when referencing that element. For instance
10467 when selecting one component of a record, this specific component
10468 should be fixed at that point in time. Or when printing the value
10469 of a record, each component should be fixed before its value gets
10470 printed. Similarly for arrays, the element of the array should be
10471 fixed when printing each element of the array, or when extracting
10472 one element out of that array. On the other hand, fixing should
10473 not be performed on the elements when taking a slice of an array!
10474
31432a67 10475 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10476 size of each field is that we end up also miscomputing the size
10477 of the containing type. This can have adverse results when computing
10478 the value of an entity. GDB fetches the value of an entity based
10479 on the size of its type, and thus a wrong size causes GDB to fetch
10480 the wrong amount of memory. In the case where the computed size is
10481 too small, GDB fetches too little data to print the value of our
31432a67 10482 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10483 past the buffer containing the data =:-o. */
10484
ced9779b
JB
10485/* Evaluate a subexpression of EXP, at index *POS, and return a value
10486 for that subexpression cast to TO_TYPE. Advance *POS over the
10487 subexpression. */
10488
10489static value *
10490ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10491 enum noside noside, struct type *to_type)
10492{
10493 int pc = *pos;
10494
10495 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10496 || exp->elts[pc].opcode == OP_VAR_VALUE)
10497 {
10498 (*pos) += 4;
10499
10500 value *val;
10501 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10502 {
10503 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10504 return value_zero (to_type, not_lval);
10505
10506 val = evaluate_var_msym_value (noside,
10507 exp->elts[pc + 1].objfile,
10508 exp->elts[pc + 2].msymbol);
10509 }
10510 else
10511 val = evaluate_var_value (noside,
10512 exp->elts[pc + 1].block,
10513 exp->elts[pc + 2].symbol);
10514
10515 if (noside == EVAL_SKIP)
10516 return eval_skip_value (exp);
10517
10518 val = ada_value_cast (to_type, val);
10519
10520 /* Follow the Ada language semantics that do not allow taking
10521 an address of the result of a cast (view conversion in Ada). */
10522 if (VALUE_LVAL (val) == lval_memory)
10523 {
10524 if (value_lazy (val))
10525 value_fetch_lazy (val);
10526 VALUE_LVAL (val) = not_lval;
10527 }
10528 return val;
10529 }
10530
10531 value *val = evaluate_subexp (to_type, exp, pos, noside);
10532 if (noside == EVAL_SKIP)
10533 return eval_skip_value (exp);
10534 return ada_value_cast (to_type, val);
10535}
10536
284614f0
JB
10537/* Implement the evaluate_exp routine in the exp_descriptor structure
10538 for the Ada language. */
10539
52ce6436 10540static struct value *
ebf56fd3 10541ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10542 int *pos, enum noside noside)
14f9c5c9
AS
10543{
10544 enum exp_opcode op;
b5385fc0 10545 int tem;
14f9c5c9 10546 int pc;
5ec18f2b 10547 int preeval_pos;
14f9c5c9
AS
10548 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10549 struct type *type;
52ce6436 10550 int nargs, oplen;
d2e4a39e 10551 struct value **argvec;
14f9c5c9 10552
d2e4a39e
AS
10553 pc = *pos;
10554 *pos += 1;
14f9c5c9
AS
10555 op = exp->elts[pc].opcode;
10556
d2e4a39e 10557 switch (op)
14f9c5c9
AS
10558 {
10559 default:
10560 *pos -= 1;
6e48bd2c 10561 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10562
10563 if (noside == EVAL_NORMAL)
10564 arg1 = unwrap_value (arg1);
6e48bd2c 10565
edd079d9 10566 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10567 then we need to perform the conversion manually, because
10568 evaluate_subexp_standard doesn't do it. This conversion is
10569 necessary in Ada because the different kinds of float/fixed
10570 types in Ada have different representations.
10571
10572 Similarly, we need to perform the conversion from OP_LONG
10573 ourselves. */
edd079d9 10574 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10575 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10576
10577 return arg1;
4c4b4cd2
PH
10578
10579 case OP_STRING:
10580 {
76a01679 10581 struct value *result;
5b4ee69b 10582
76a01679
JB
10583 *pos -= 1;
10584 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10585 /* The result type will have code OP_STRING, bashed there from
10586 OP_ARRAY. Bash it back. */
df407dfe
AC
10587 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10588 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10589 return result;
4c4b4cd2 10590 }
14f9c5c9
AS
10591
10592 case UNOP_CAST:
10593 (*pos) += 2;
10594 type = exp->elts[pc + 1].type;
ced9779b 10595 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10596
4c4b4cd2
PH
10597 case UNOP_QUAL:
10598 (*pos) += 2;
10599 type = exp->elts[pc + 1].type;
10600 return ada_evaluate_subexp (type, exp, pos, noside);
10601
14f9c5c9
AS
10602 case BINOP_ASSIGN:
10603 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10604 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10605 {
10606 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10607 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10608 return arg1;
10609 return ada_value_assign (arg1, arg1);
10610 }
003f3813
JB
10611 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10612 except if the lhs of our assignment is a convenience variable.
10613 In the case of assigning to a convenience variable, the lhs
10614 should be exactly the result of the evaluation of the rhs. */
10615 type = value_type (arg1);
10616 if (VALUE_LVAL (arg1) == lval_internalvar)
10617 type = NULL;
10618 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10619 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10620 return arg1;
df407dfe
AC
10621 if (ada_is_fixed_point_type (value_type (arg1)))
10622 arg2 = cast_to_fixed (value_type (arg1), arg2);
10623 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10624 error
323e0a4a 10625 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10626 else
df407dfe 10627 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10628 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10629
10630 case BINOP_ADD:
10631 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10632 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10633 if (noside == EVAL_SKIP)
4c4b4cd2 10634 goto nosideret;
2ac8a782
JB
10635 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10636 return (value_from_longest
10637 (value_type (arg1),
10638 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10639 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10640 return (value_from_longest
10641 (value_type (arg2),
10642 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10643 if ((ada_is_fixed_point_type (value_type (arg1))
10644 || ada_is_fixed_point_type (value_type (arg2)))
10645 && value_type (arg1) != value_type (arg2))
323e0a4a 10646 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10647 /* Do the addition, and cast the result to the type of the first
10648 argument. We cannot cast the result to a reference type, so if
10649 ARG1 is a reference type, find its underlying type. */
10650 type = value_type (arg1);
10651 while (TYPE_CODE (type) == TYPE_CODE_REF)
10652 type = TYPE_TARGET_TYPE (type);
f44316fa 10653 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10654 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10655
10656 case BINOP_SUB:
10657 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10658 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10659 if (noside == EVAL_SKIP)
4c4b4cd2 10660 goto nosideret;
2ac8a782
JB
10661 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10662 return (value_from_longest
10663 (value_type (arg1),
10664 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10665 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10666 return (value_from_longest
10667 (value_type (arg2),
10668 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10669 if ((ada_is_fixed_point_type (value_type (arg1))
10670 || ada_is_fixed_point_type (value_type (arg2)))
10671 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10672 error (_("Operands of fixed-point subtraction "
10673 "must have the same type"));
b7789565
JB
10674 /* Do the substraction, and cast the result to the type of the first
10675 argument. We cannot cast the result to a reference type, so if
10676 ARG1 is a reference type, find its underlying type. */
10677 type = value_type (arg1);
10678 while (TYPE_CODE (type) == TYPE_CODE_REF)
10679 type = TYPE_TARGET_TYPE (type);
f44316fa 10680 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10681 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10682
10683 case BINOP_MUL:
10684 case BINOP_DIV:
e1578042
JB
10685 case BINOP_REM:
10686 case BINOP_MOD:
14f9c5c9
AS
10687 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10688 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10689 if (noside == EVAL_SKIP)
4c4b4cd2 10690 goto nosideret;
e1578042 10691 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10692 {
10693 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10694 return value_zero (value_type (arg1), not_lval);
10695 }
14f9c5c9 10696 else
4c4b4cd2 10697 {
a53b7a21 10698 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10699 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10700 arg1 = cast_from_fixed (type, arg1);
df407dfe 10701 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10702 arg2 = cast_from_fixed (type, arg2);
f44316fa 10703 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10704 return ada_value_binop (arg1, arg2, op);
10705 }
10706
4c4b4cd2
PH
10707 case BINOP_EQUAL:
10708 case BINOP_NOTEQUAL:
14f9c5c9 10709 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10710 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10711 if (noside == EVAL_SKIP)
76a01679 10712 goto nosideret;
4c4b4cd2 10713 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10714 tem = 0;
4c4b4cd2 10715 else
f44316fa
UW
10716 {
10717 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10718 tem = ada_value_equal (arg1, arg2);
10719 }
4c4b4cd2 10720 if (op == BINOP_NOTEQUAL)
76a01679 10721 tem = !tem;
fbb06eb1
UW
10722 type = language_bool_type (exp->language_defn, exp->gdbarch);
10723 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10724
10725 case UNOP_NEG:
10726 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10727 if (noside == EVAL_SKIP)
10728 goto nosideret;
df407dfe
AC
10729 else if (ada_is_fixed_point_type (value_type (arg1)))
10730 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10731 else
f44316fa
UW
10732 {
10733 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10734 return value_neg (arg1);
10735 }
4c4b4cd2 10736
2330c6c6
JB
10737 case BINOP_LOGICAL_AND:
10738 case BINOP_LOGICAL_OR:
10739 case UNOP_LOGICAL_NOT:
000d5124
JB
10740 {
10741 struct value *val;
10742
10743 *pos -= 1;
10744 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10745 type = language_bool_type (exp->language_defn, exp->gdbarch);
10746 return value_cast (type, val);
000d5124 10747 }
2330c6c6
JB
10748
10749 case BINOP_BITWISE_AND:
10750 case BINOP_BITWISE_IOR:
10751 case BINOP_BITWISE_XOR:
000d5124
JB
10752 {
10753 struct value *val;
10754
10755 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10756 *pos = pc;
10757 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10758
10759 return value_cast (value_type (arg1), val);
10760 }
2330c6c6 10761
14f9c5c9
AS
10762 case OP_VAR_VALUE:
10763 *pos -= 1;
6799def4 10764
14f9c5c9 10765 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10766 {
10767 *pos += 4;
10768 goto nosideret;
10769 }
da5c522f
JB
10770
10771 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10772 /* Only encountered when an unresolved symbol occurs in a
10773 context other than a function call, in which case, it is
52ce6436 10774 invalid. */
323e0a4a 10775 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10776 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10777
10778 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10779 {
0c1f74cf 10780 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10781 /* Check to see if this is a tagged type. We also need to handle
10782 the case where the type is a reference to a tagged type, but
10783 we have to be careful to exclude pointers to tagged types.
10784 The latter should be shown as usual (as a pointer), whereas
10785 a reference should mostly be transparent to the user. */
10786 if (ada_is_tagged_type (type, 0)
023db19c 10787 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10788 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10789 {
10790 /* Tagged types are a little special in the fact that the real
10791 type is dynamic and can only be determined by inspecting the
10792 object's tag. This means that we need to get the object's
10793 value first (EVAL_NORMAL) and then extract the actual object
10794 type from its tag.
10795
10796 Note that we cannot skip the final step where we extract
10797 the object type from its tag, because the EVAL_NORMAL phase
10798 results in dynamic components being resolved into fixed ones.
10799 This can cause problems when trying to print the type
10800 description of tagged types whose parent has a dynamic size:
10801 We use the type name of the "_parent" component in order
10802 to print the name of the ancestor type in the type description.
10803 If that component had a dynamic size, the resolution into
10804 a fixed type would result in the loss of that type name,
10805 thus preventing us from printing the name of the ancestor
10806 type in the type description. */
10807 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10808
10809 if (TYPE_CODE (type) != TYPE_CODE_REF)
10810 {
10811 struct type *actual_type;
10812
10813 actual_type = type_from_tag (ada_value_tag (arg1));
10814 if (actual_type == NULL)
10815 /* If, for some reason, we were unable to determine
10816 the actual type from the tag, then use the static
10817 approximation that we just computed as a fallback.
10818 This can happen if the debugging information is
10819 incomplete, for instance. */
10820 actual_type = type;
10821 return value_zero (actual_type, not_lval);
10822 }
10823 else
10824 {
10825 /* In the case of a ref, ada_coerce_ref takes care
10826 of determining the actual type. But the evaluation
10827 should return a ref as it should be valid to ask
10828 for its address; so rebuild a ref after coerce. */
10829 arg1 = ada_coerce_ref (arg1);
a65cfae5 10830 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10831 }
10832 }
0c1f74cf 10833
84754697
JB
10834 /* Records and unions for which GNAT encodings have been
10835 generated need to be statically fixed as well.
10836 Otherwise, non-static fixing produces a type where
10837 all dynamic properties are removed, which prevents "ptype"
10838 from being able to completely describe the type.
10839 For instance, a case statement in a variant record would be
10840 replaced by the relevant components based on the actual
10841 value of the discriminants. */
10842 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10843 && dynamic_template_type (type) != NULL)
10844 || (TYPE_CODE (type) == TYPE_CODE_UNION
10845 && ada_find_parallel_type (type, "___XVU") != NULL))
10846 {
10847 *pos += 4;
10848 return value_zero (to_static_fixed_type (type), not_lval);
10849 }
4c4b4cd2 10850 }
da5c522f
JB
10851
10852 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10853 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10854
10855 case OP_FUNCALL:
10856 (*pos) += 2;
10857
10858 /* Allocate arg vector, including space for the function to be
10859 called in argvec[0] and a terminating NULL. */
10860 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10861 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10862
10863 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10864 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10865 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10866 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10867 else
10868 {
10869 for (tem = 0; tem <= nargs; tem += 1)
10870 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10871 argvec[tem] = 0;
10872
10873 if (noside == EVAL_SKIP)
10874 goto nosideret;
10875 }
10876
ad82864c
JB
10877 if (ada_is_constrained_packed_array_type
10878 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10879 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10880 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10881 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10882 /* This is a packed array that has already been fixed, and
10883 therefore already coerced to a simple array. Nothing further
10884 to do. */
10885 ;
e6c2c623
PMR
10886 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10887 {
10888 /* Make sure we dereference references so that all the code below
10889 feels like it's really handling the referenced value. Wrapping
10890 types (for alignment) may be there, so make sure we strip them as
10891 well. */
10892 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10893 }
10894 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10895 && VALUE_LVAL (argvec[0]) == lval_memory)
10896 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10897
df407dfe 10898 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10899
10900 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10901 them. So, if this is an array typedef (encoding use for array
10902 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10903 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10904 type = ada_typedef_target_type (type);
10905
4c4b4cd2
PH
10906 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10907 {
61ee279c 10908 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10909 {
10910 case TYPE_CODE_FUNC:
61ee279c 10911 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10912 break;
10913 case TYPE_CODE_ARRAY:
10914 break;
10915 case TYPE_CODE_STRUCT:
10916 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10917 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10918 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10919 break;
10920 default:
323e0a4a 10921 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10922 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10923 break;
10924 }
10925 }
10926
10927 switch (TYPE_CODE (type))
10928 {
10929 case TYPE_CODE_FUNC:
10930 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10931 {
7022349d
PA
10932 if (TYPE_TARGET_TYPE (type) == NULL)
10933 error_call_unknown_return_type (NULL);
10934 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10935 }
e71585ff
PA
10936 return call_function_by_hand (argvec[0], NULL,
10937 gdb::make_array_view (argvec + 1,
10938 nargs));
c8ea1972
PH
10939 case TYPE_CODE_INTERNAL_FUNCTION:
10940 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10941 /* We don't know anything about what the internal
10942 function might return, but we have to return
10943 something. */
10944 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10945 not_lval);
10946 else
10947 return call_internal_function (exp->gdbarch, exp->language_defn,
10948 argvec[0], nargs, argvec + 1);
10949
4c4b4cd2
PH
10950 case TYPE_CODE_STRUCT:
10951 {
10952 int arity;
10953
4c4b4cd2
PH
10954 arity = ada_array_arity (type);
10955 type = ada_array_element_type (type, nargs);
10956 if (type == NULL)
323e0a4a 10957 error (_("cannot subscript or call a record"));
4c4b4cd2 10958 if (arity != nargs)
323e0a4a 10959 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10960 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10961 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10962 return
10963 unwrap_value (ada_value_subscript
10964 (argvec[0], nargs, argvec + 1));
10965 }
10966 case TYPE_CODE_ARRAY:
10967 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10968 {
10969 type = ada_array_element_type (type, nargs);
10970 if (type == NULL)
323e0a4a 10971 error (_("element type of array unknown"));
4c4b4cd2 10972 else
0a07e705 10973 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10974 }
10975 return
10976 unwrap_value (ada_value_subscript
10977 (ada_coerce_to_simple_array (argvec[0]),
10978 nargs, argvec + 1));
10979 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10980 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10981 {
deede10c 10982 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10983 type = ada_array_element_type (type, nargs);
10984 if (type == NULL)
323e0a4a 10985 error (_("element type of array unknown"));
4c4b4cd2 10986 else
0a07e705 10987 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10988 }
10989 return
deede10c
JB
10990 unwrap_value (ada_value_ptr_subscript (argvec[0],
10991 nargs, argvec + 1));
4c4b4cd2
PH
10992
10993 default:
e1d5a0d2
PH
10994 error (_("Attempt to index or call something other than an "
10995 "array or function"));
4c4b4cd2
PH
10996 }
10997
10998 case TERNOP_SLICE:
10999 {
11000 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11001 struct value *low_bound_val =
11002 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
11003 struct value *high_bound_val =
11004 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11005 LONGEST low_bound;
11006 LONGEST high_bound;
5b4ee69b 11007
994b9211
AC
11008 low_bound_val = coerce_ref (low_bound_val);
11009 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
11010 low_bound = value_as_long (low_bound_val);
11011 high_bound = value_as_long (high_bound_val);
963a6417 11012
4c4b4cd2
PH
11013 if (noside == EVAL_SKIP)
11014 goto nosideret;
11015
4c4b4cd2
PH
11016 /* If this is a reference to an aligner type, then remove all
11017 the aligners. */
df407dfe
AC
11018 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11019 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11020 TYPE_TARGET_TYPE (value_type (array)) =
11021 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 11022
ad82864c 11023 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 11024 error (_("cannot slice a packed array"));
4c4b4cd2
PH
11025
11026 /* If this is a reference to an array or an array lvalue,
11027 convert to a pointer. */
df407dfe
AC
11028 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11029 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
11030 && VALUE_LVAL (array) == lval_memory))
11031 array = value_addr (array);
11032
1265e4aa 11033 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 11034 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 11035 (value_type (array))))
0b5d8877 11036 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
11037
11038 array = ada_coerce_to_simple_array_ptr (array);
11039
714e53ab
PH
11040 /* If we have more than one level of pointer indirection,
11041 dereference the value until we get only one level. */
df407dfe
AC
11042 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11043 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
11044 == TYPE_CODE_PTR))
11045 array = value_ind (array);
11046
11047 /* Make sure we really do have an array type before going further,
11048 to avoid a SEGV when trying to get the index type or the target
11049 type later down the road if the debug info generated by
11050 the compiler is incorrect or incomplete. */
df407dfe 11051 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 11052 error (_("cannot take slice of non-array"));
714e53ab 11053
828292f2
JB
11054 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11055 == TYPE_CODE_PTR)
4c4b4cd2 11056 {
828292f2
JB
11057 struct type *type0 = ada_check_typedef (value_type (array));
11058
0b5d8877 11059 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 11060 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
11061 else
11062 {
11063 struct type *arr_type0 =
828292f2 11064 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 11065
f5938064
JG
11066 return ada_value_slice_from_ptr (array, arr_type0,
11067 longest_to_int (low_bound),
11068 longest_to_int (high_bound));
4c4b4cd2
PH
11069 }
11070 }
11071 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11072 return array;
11073 else if (high_bound < low_bound)
df407dfe 11074 return empty_array (value_type (array), low_bound);
4c4b4cd2 11075 else
529cad9c
PH
11076 return ada_value_slice (array, longest_to_int (low_bound),
11077 longest_to_int (high_bound));
4c4b4cd2 11078 }
14f9c5c9 11079
4c4b4cd2
PH
11080 case UNOP_IN_RANGE:
11081 (*pos) += 2;
11082 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 11083 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 11084
14f9c5c9 11085 if (noside == EVAL_SKIP)
4c4b4cd2 11086 goto nosideret;
14f9c5c9 11087
4c4b4cd2
PH
11088 switch (TYPE_CODE (type))
11089 {
11090 default:
e1d5a0d2
PH
11091 lim_warning (_("Membership test incompletely implemented; "
11092 "always returns true"));
fbb06eb1
UW
11093 type = language_bool_type (exp->language_defn, exp->gdbarch);
11094 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
11095
11096 case TYPE_CODE_RANGE:
030b4912
UW
11097 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11098 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
11099 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11100 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
11101 type = language_bool_type (exp->language_defn, exp->gdbarch);
11102 return
11103 value_from_longest (type,
4c4b4cd2
PH
11104 (value_less (arg1, arg3)
11105 || value_equal (arg1, arg3))
11106 && (value_less (arg2, arg1)
11107 || value_equal (arg2, arg1)));
11108 }
11109
11110 case BINOP_IN_BOUNDS:
14f9c5c9 11111 (*pos) += 2;
4c4b4cd2
PH
11112 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11113 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11114
4c4b4cd2
PH
11115 if (noside == EVAL_SKIP)
11116 goto nosideret;
14f9c5c9 11117
4c4b4cd2 11118 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
11119 {
11120 type = language_bool_type (exp->language_defn, exp->gdbarch);
11121 return value_zero (type, not_lval);
11122 }
14f9c5c9 11123
4c4b4cd2 11124 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11125
1eea4ebd
UW
11126 type = ada_index_type (value_type (arg2), tem, "range");
11127 if (!type)
11128 type = value_type (arg1);
14f9c5c9 11129
1eea4ebd
UW
11130 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11131 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11132
f44316fa
UW
11133 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11134 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11135 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11136 return
fbb06eb1 11137 value_from_longest (type,
4c4b4cd2
PH
11138 (value_less (arg1, arg3)
11139 || value_equal (arg1, arg3))
11140 && (value_less (arg2, arg1)
11141 || value_equal (arg2, arg1)));
11142
11143 case TERNOP_IN_RANGE:
11144 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11145 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11146 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11147
11148 if (noside == EVAL_SKIP)
11149 goto nosideret;
11150
f44316fa
UW
11151 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11152 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11153 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11154 return
fbb06eb1 11155 value_from_longest (type,
4c4b4cd2
PH
11156 (value_less (arg1, arg3)
11157 || value_equal (arg1, arg3))
11158 && (value_less (arg2, arg1)
11159 || value_equal (arg2, arg1)));
11160
11161 case OP_ATR_FIRST:
11162 case OP_ATR_LAST:
11163 case OP_ATR_LENGTH:
11164 {
76a01679 11165 struct type *type_arg;
5b4ee69b 11166
76a01679
JB
11167 if (exp->elts[*pos].opcode == OP_TYPE)
11168 {
11169 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11170 arg1 = NULL;
5bc23cb3 11171 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11172 }
11173 else
11174 {
11175 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11176 type_arg = NULL;
11177 }
11178
11179 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11180 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11181 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11182 *pos += 4;
11183
11184 if (noside == EVAL_SKIP)
11185 goto nosideret;
11186
11187 if (type_arg == NULL)
11188 {
11189 arg1 = ada_coerce_ref (arg1);
11190
ad82864c 11191 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11192 arg1 = ada_coerce_to_simple_array (arg1);
11193
aa4fb036 11194 if (op == OP_ATR_LENGTH)
1eea4ebd 11195 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11196 else
11197 {
11198 type = ada_index_type (value_type (arg1), tem,
11199 ada_attribute_name (op));
11200 if (type == NULL)
11201 type = builtin_type (exp->gdbarch)->builtin_int;
11202 }
76a01679
JB
11203
11204 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11205 return allocate_value (type);
76a01679
JB
11206
11207 switch (op)
11208 {
11209 default: /* Should never happen. */
323e0a4a 11210 error (_("unexpected attribute encountered"));
76a01679 11211 case OP_ATR_FIRST:
1eea4ebd
UW
11212 return value_from_longest
11213 (type, ada_array_bound (arg1, tem, 0));
76a01679 11214 case OP_ATR_LAST:
1eea4ebd
UW
11215 return value_from_longest
11216 (type, ada_array_bound (arg1, tem, 1));
76a01679 11217 case OP_ATR_LENGTH:
1eea4ebd
UW
11218 return value_from_longest
11219 (type, ada_array_length (arg1, tem));
76a01679
JB
11220 }
11221 }
11222 else if (discrete_type_p (type_arg))
11223 {
11224 struct type *range_type;
0d5cff50 11225 const char *name = ada_type_name (type_arg);
5b4ee69b 11226
76a01679
JB
11227 range_type = NULL;
11228 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11229 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11230 if (range_type == NULL)
11231 range_type = type_arg;
11232 switch (op)
11233 {
11234 default:
323e0a4a 11235 error (_("unexpected attribute encountered"));
76a01679 11236 case OP_ATR_FIRST:
690cc4eb 11237 return value_from_longest
43bbcdc2 11238 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11239 case OP_ATR_LAST:
690cc4eb 11240 return value_from_longest
43bbcdc2 11241 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11242 case OP_ATR_LENGTH:
323e0a4a 11243 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11244 }
11245 }
11246 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11247 error (_("unimplemented type attribute"));
76a01679
JB
11248 else
11249 {
11250 LONGEST low, high;
11251
ad82864c
JB
11252 if (ada_is_constrained_packed_array_type (type_arg))
11253 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11254
aa4fb036 11255 if (op == OP_ATR_LENGTH)
1eea4ebd 11256 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11257 else
11258 {
11259 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11260 if (type == NULL)
11261 type = builtin_type (exp->gdbarch)->builtin_int;
11262 }
1eea4ebd 11263
76a01679
JB
11264 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11265 return allocate_value (type);
11266
11267 switch (op)
11268 {
11269 default:
323e0a4a 11270 error (_("unexpected attribute encountered"));
76a01679 11271 case OP_ATR_FIRST:
1eea4ebd 11272 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11273 return value_from_longest (type, low);
11274 case OP_ATR_LAST:
1eea4ebd 11275 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11276 return value_from_longest (type, high);
11277 case OP_ATR_LENGTH:
1eea4ebd
UW
11278 low = ada_array_bound_from_type (type_arg, tem, 0);
11279 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11280 return value_from_longest (type, high - low + 1);
11281 }
11282 }
14f9c5c9
AS
11283 }
11284
4c4b4cd2
PH
11285 case OP_ATR_TAG:
11286 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11287 if (noside == EVAL_SKIP)
76a01679 11288 goto nosideret;
4c4b4cd2
PH
11289
11290 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11291 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11292
11293 return ada_value_tag (arg1);
11294
11295 case OP_ATR_MIN:
11296 case OP_ATR_MAX:
11297 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11298 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11299 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11300 if (noside == EVAL_SKIP)
76a01679 11301 goto nosideret;
d2e4a39e 11302 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11303 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11304 else
f44316fa
UW
11305 {
11306 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11307 return value_binop (arg1, arg2,
11308 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11309 }
14f9c5c9 11310
4c4b4cd2
PH
11311 case OP_ATR_MODULUS:
11312 {
31dedfee 11313 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11314
5b4ee69b 11315 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11316 if (noside == EVAL_SKIP)
11317 goto nosideret;
4c4b4cd2 11318
76a01679 11319 if (!ada_is_modular_type (type_arg))
323e0a4a 11320 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11321
76a01679
JB
11322 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11323 ada_modulus (type_arg));
4c4b4cd2
PH
11324 }
11325
11326
11327 case OP_ATR_POS:
11328 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11329 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11330 if (noside == EVAL_SKIP)
76a01679 11331 goto nosideret;
3cb382c9
UW
11332 type = builtin_type (exp->gdbarch)->builtin_int;
11333 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11334 return value_zero (type, not_lval);
14f9c5c9 11335 else
3cb382c9 11336 return value_pos_atr (type, arg1);
14f9c5c9 11337
4c4b4cd2
PH
11338 case OP_ATR_SIZE:
11339 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11340 type = value_type (arg1);
11341
11342 /* If the argument is a reference, then dereference its type, since
11343 the user is really asking for the size of the actual object,
11344 not the size of the pointer. */
11345 if (TYPE_CODE (type) == TYPE_CODE_REF)
11346 type = TYPE_TARGET_TYPE (type);
11347
4c4b4cd2 11348 if (noside == EVAL_SKIP)
76a01679 11349 goto nosideret;
4c4b4cd2 11350 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11351 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11352 else
22601c15 11353 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11354 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11355
11356 case OP_ATR_VAL:
11357 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11358 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11359 type = exp->elts[pc + 2].type;
14f9c5c9 11360 if (noside == EVAL_SKIP)
76a01679 11361 goto nosideret;
4c4b4cd2 11362 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11363 return value_zero (type, not_lval);
4c4b4cd2 11364 else
76a01679 11365 return value_val_atr (type, arg1);
4c4b4cd2
PH
11366
11367 case BINOP_EXP:
11368 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11369 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11370 if (noside == EVAL_SKIP)
11371 goto nosideret;
11372 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11373 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11374 else
f44316fa
UW
11375 {
11376 /* For integer exponentiation operations,
11377 only promote the first argument. */
11378 if (is_integral_type (value_type (arg2)))
11379 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11380 else
11381 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11382
11383 return value_binop (arg1, arg2, op);
11384 }
4c4b4cd2
PH
11385
11386 case UNOP_PLUS:
11387 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11388 if (noside == EVAL_SKIP)
11389 goto nosideret;
11390 else
11391 return arg1;
11392
11393 case UNOP_ABS:
11394 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11395 if (noside == EVAL_SKIP)
11396 goto nosideret;
f44316fa 11397 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11398 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11399 return value_neg (arg1);
14f9c5c9 11400 else
4c4b4cd2 11401 return arg1;
14f9c5c9
AS
11402
11403 case UNOP_IND:
5ec18f2b 11404 preeval_pos = *pos;
6b0d7253 11405 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11406 if (noside == EVAL_SKIP)
4c4b4cd2 11407 goto nosideret;
df407dfe 11408 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11409 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11410 {
11411 if (ada_is_array_descriptor_type (type))
11412 /* GDB allows dereferencing GNAT array descriptors. */
11413 {
11414 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11415
4c4b4cd2 11416 if (arrType == NULL)
323e0a4a 11417 error (_("Attempt to dereference null array pointer."));
00a4c844 11418 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11419 }
11420 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11421 || TYPE_CODE (type) == TYPE_CODE_REF
11422 /* In C you can dereference an array to get the 1st elt. */
11423 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11424 {
5ec18f2b
JG
11425 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11426 only be determined by inspecting the object's tag.
11427 This means that we need to evaluate completely the
11428 expression in order to get its type. */
11429
023db19c
JB
11430 if ((TYPE_CODE (type) == TYPE_CODE_REF
11431 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11432 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11433 {
11434 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11435 EVAL_NORMAL);
11436 type = value_type (ada_value_ind (arg1));
11437 }
11438 else
11439 {
11440 type = to_static_fixed_type
11441 (ada_aligned_type
11442 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11443 }
c1b5a1a6 11444 ada_ensure_varsize_limit (type);
714e53ab
PH
11445 return value_zero (type, lval_memory);
11446 }
4c4b4cd2 11447 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11448 {
11449 /* GDB allows dereferencing an int. */
11450 if (expect_type == NULL)
11451 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11452 lval_memory);
11453 else
11454 {
11455 expect_type =
11456 to_static_fixed_type (ada_aligned_type (expect_type));
11457 return value_zero (expect_type, lval_memory);
11458 }
11459 }
4c4b4cd2 11460 else
323e0a4a 11461 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11462 }
0963b4bd 11463 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11464 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11465
96967637
JB
11466 if (TYPE_CODE (type) == TYPE_CODE_INT)
11467 /* GDB allows dereferencing an int. If we were given
11468 the expect_type, then use that as the target type.
11469 Otherwise, assume that the target type is an int. */
11470 {
11471 if (expect_type != NULL)
11472 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11473 arg1));
11474 else
11475 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11476 (CORE_ADDR) value_as_address (arg1));
11477 }
6b0d7253 11478
4c4b4cd2
PH
11479 if (ada_is_array_descriptor_type (type))
11480 /* GDB allows dereferencing GNAT array descriptors. */
11481 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11482 else
4c4b4cd2 11483 return ada_value_ind (arg1);
14f9c5c9
AS
11484
11485 case STRUCTOP_STRUCT:
11486 tem = longest_to_int (exp->elts[pc + 1].longconst);
11487 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11488 preeval_pos = *pos;
14f9c5c9
AS
11489 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11490 if (noside == EVAL_SKIP)
4c4b4cd2 11491 goto nosideret;
14f9c5c9 11492 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11493 {
df407dfe 11494 struct type *type1 = value_type (arg1);
5b4ee69b 11495
76a01679
JB
11496 if (ada_is_tagged_type (type1, 1))
11497 {
11498 type = ada_lookup_struct_elt_type (type1,
11499 &exp->elts[pc + 2].string,
988f6b3d 11500 1, 1);
5ec18f2b
JG
11501
11502 /* If the field is not found, check if it exists in the
11503 extension of this object's type. This means that we
11504 need to evaluate completely the expression. */
11505
76a01679 11506 if (type == NULL)
5ec18f2b
JG
11507 {
11508 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11509 EVAL_NORMAL);
11510 arg1 = ada_value_struct_elt (arg1,
11511 &exp->elts[pc + 2].string,
11512 0);
11513 arg1 = unwrap_value (arg1);
11514 type = value_type (ada_to_fixed_value (arg1));
11515 }
76a01679
JB
11516 }
11517 else
11518 type =
11519 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11520 0);
76a01679
JB
11521
11522 return value_zero (ada_aligned_type (type), lval_memory);
11523 }
14f9c5c9 11524 else
a579cd9a
MW
11525 {
11526 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11527 arg1 = unwrap_value (arg1);
11528 return ada_to_fixed_value (arg1);
11529 }
284614f0 11530
14f9c5c9 11531 case OP_TYPE:
4c4b4cd2
PH
11532 /* The value is not supposed to be used. This is here to make it
11533 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11534 (*pos) += 2;
11535 if (noside == EVAL_SKIP)
4c4b4cd2 11536 goto nosideret;
14f9c5c9 11537 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11538 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11539 else
323e0a4a 11540 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11541
11542 case OP_AGGREGATE:
11543 case OP_CHOICES:
11544 case OP_OTHERS:
11545 case OP_DISCRETE_RANGE:
11546 case OP_POSITIONAL:
11547 case OP_NAME:
11548 if (noside == EVAL_NORMAL)
11549 switch (op)
11550 {
11551 case OP_NAME:
11552 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11553 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11554 case OP_AGGREGATE:
11555 error (_("Aggregates only allowed on the right of an assignment"));
11556 default:
0963b4bd
MS
11557 internal_error (__FILE__, __LINE__,
11558 _("aggregate apparently mangled"));
52ce6436
PH
11559 }
11560
11561 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11562 *pos += oplen - 1;
11563 for (tem = 0; tem < nargs; tem += 1)
11564 ada_evaluate_subexp (NULL, exp, pos, noside);
11565 goto nosideret;
14f9c5c9
AS
11566 }
11567
11568nosideret:
ced9779b 11569 return eval_skip_value (exp);
14f9c5c9 11570}
14f9c5c9 11571\f
d2e4a39e 11572
4c4b4cd2 11573 /* Fixed point */
14f9c5c9
AS
11574
11575/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11576 type name that encodes the 'small and 'delta information.
4c4b4cd2 11577 Otherwise, return NULL. */
14f9c5c9 11578
d2e4a39e 11579static const char *
ebf56fd3 11580fixed_type_info (struct type *type)
14f9c5c9 11581{
d2e4a39e 11582 const char *name = ada_type_name (type);
14f9c5c9
AS
11583 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11584
d2e4a39e
AS
11585 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11586 {
14f9c5c9 11587 const char *tail = strstr (name, "___XF_");
5b4ee69b 11588
14f9c5c9 11589 if (tail == NULL)
4c4b4cd2 11590 return NULL;
d2e4a39e 11591 else
4c4b4cd2 11592 return tail + 5;
14f9c5c9
AS
11593 }
11594 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11595 return fixed_type_info (TYPE_TARGET_TYPE (type));
11596 else
11597 return NULL;
11598}
11599
4c4b4cd2 11600/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11601
11602int
ebf56fd3 11603ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11604{
11605 return fixed_type_info (type) != NULL;
11606}
11607
4c4b4cd2
PH
11608/* Return non-zero iff TYPE represents a System.Address type. */
11609
11610int
11611ada_is_system_address_type (struct type *type)
11612{
11613 return (TYPE_NAME (type)
11614 && strcmp (TYPE_NAME (type), "system__address") == 0);
11615}
11616
14f9c5c9 11617/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11618 type, return the target floating-point type to be used to represent
11619 of this type during internal computation. */
11620
11621static struct type *
11622ada_scaling_type (struct type *type)
11623{
11624 return builtin_type (get_type_arch (type))->builtin_long_double;
11625}
11626
11627/* Assuming that TYPE is the representation of an Ada fixed-point
11628 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11629 delta cannot be determined. */
14f9c5c9 11630
50eff16b 11631struct value *
ebf56fd3 11632ada_delta (struct type *type)
14f9c5c9
AS
11633{
11634 const char *encoding = fixed_type_info (type);
50eff16b
UW
11635 struct type *scale_type = ada_scaling_type (type);
11636
11637 long long num, den;
11638
11639 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11640 return nullptr;
d2e4a39e 11641 else
50eff16b
UW
11642 return value_binop (value_from_longest (scale_type, num),
11643 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11644}
11645
11646/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11647 factor ('SMALL value) associated with the type. */
14f9c5c9 11648
50eff16b
UW
11649struct value *
11650ada_scaling_factor (struct type *type)
14f9c5c9
AS
11651{
11652 const char *encoding = fixed_type_info (type);
50eff16b
UW
11653 struct type *scale_type = ada_scaling_type (type);
11654
11655 long long num0, den0, num1, den1;
14f9c5c9 11656 int n;
d2e4a39e 11657
50eff16b 11658 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11659 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11660
11661 if (n < 2)
50eff16b 11662 return value_from_longest (scale_type, 1);
14f9c5c9 11663 else if (n == 4)
50eff16b
UW
11664 return value_binop (value_from_longest (scale_type, num1),
11665 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11666 else
50eff16b
UW
11667 return value_binop (value_from_longest (scale_type, num0),
11668 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11669}
11670
14f9c5c9 11671\f
d2e4a39e 11672
4c4b4cd2 11673 /* Range types */
14f9c5c9
AS
11674
11675/* Scan STR beginning at position K for a discriminant name, and
11676 return the value of that discriminant field of DVAL in *PX. If
11677 PNEW_K is not null, put the position of the character beyond the
11678 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11679 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11680
11681static int
108d56a4 11682scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11683 int *pnew_k)
14f9c5c9
AS
11684{
11685 static char *bound_buffer = NULL;
11686 static size_t bound_buffer_len = 0;
5da1a4d3 11687 const char *pstart, *pend, *bound;
d2e4a39e 11688 struct value *bound_val;
14f9c5c9
AS
11689
11690 if (dval == NULL || str == NULL || str[k] == '\0')
11691 return 0;
11692
5da1a4d3
SM
11693 pstart = str + k;
11694 pend = strstr (pstart, "__");
14f9c5c9
AS
11695 if (pend == NULL)
11696 {
5da1a4d3 11697 bound = pstart;
14f9c5c9
AS
11698 k += strlen (bound);
11699 }
d2e4a39e 11700 else
14f9c5c9 11701 {
5da1a4d3
SM
11702 int len = pend - pstart;
11703
11704 /* Strip __ and beyond. */
11705 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11706 strncpy (bound_buffer, pstart, len);
11707 bound_buffer[len] = '\0';
11708
14f9c5c9 11709 bound = bound_buffer;
d2e4a39e 11710 k = pend - str;
14f9c5c9 11711 }
d2e4a39e 11712
df407dfe 11713 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11714 if (bound_val == NULL)
11715 return 0;
11716
11717 *px = value_as_long (bound_val);
11718 if (pnew_k != NULL)
11719 *pnew_k = k;
11720 return 1;
11721}
11722
11723/* Value of variable named NAME in the current environment. If
11724 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11725 otherwise causes an error with message ERR_MSG. */
11726
d2e4a39e 11727static struct value *
edb0c9cb 11728get_var_value (const char *name, const char *err_msg)
14f9c5c9 11729{
b5ec771e 11730 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11731
54d343a2 11732 std::vector<struct block_symbol> syms;
b5ec771e
PA
11733 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11734 get_selected_block (0),
11735 VAR_DOMAIN, &syms, 1);
14f9c5c9
AS
11736
11737 if (nsyms != 1)
11738 {
11739 if (err_msg == NULL)
4c4b4cd2 11740 return 0;
14f9c5c9 11741 else
8a3fe4f8 11742 error (("%s"), err_msg);
14f9c5c9
AS
11743 }
11744
54d343a2 11745 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11746}
d2e4a39e 11747
edb0c9cb
PA
11748/* Value of integer variable named NAME in the current environment.
11749 If no such variable is found, returns false. Otherwise, sets VALUE
11750 to the variable's value and returns true. */
4c4b4cd2 11751
edb0c9cb
PA
11752bool
11753get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11754{
4c4b4cd2 11755 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11756
14f9c5c9 11757 if (var_val == 0)
edb0c9cb
PA
11758 return false;
11759
11760 value = value_as_long (var_val);
11761 return true;
14f9c5c9 11762}
d2e4a39e 11763
14f9c5c9
AS
11764
11765/* Return a range type whose base type is that of the range type named
11766 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11767 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11768 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11769 corresponding range type from debug information; fall back to using it
11770 if symbol lookup fails. If a new type must be created, allocate it
11771 like ORIG_TYPE was. The bounds information, in general, is encoded
11772 in NAME, the base type given in the named range type. */
14f9c5c9 11773
d2e4a39e 11774static struct type *
28c85d6c 11775to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11776{
0d5cff50 11777 const char *name;
14f9c5c9 11778 struct type *base_type;
108d56a4 11779 const char *subtype_info;
14f9c5c9 11780
28c85d6c
JB
11781 gdb_assert (raw_type != NULL);
11782 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11783
1ce677a4 11784 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11785 base_type = TYPE_TARGET_TYPE (raw_type);
11786 else
11787 base_type = raw_type;
11788
28c85d6c 11789 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11790 subtype_info = strstr (name, "___XD");
11791 if (subtype_info == NULL)
690cc4eb 11792 {
43bbcdc2
PH
11793 LONGEST L = ada_discrete_type_low_bound (raw_type);
11794 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11795
690cc4eb
PH
11796 if (L < INT_MIN || U > INT_MAX)
11797 return raw_type;
11798 else
0c9c3474
SA
11799 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11800 L, U);
690cc4eb 11801 }
14f9c5c9
AS
11802 else
11803 {
11804 static char *name_buf = NULL;
11805 static size_t name_len = 0;
11806 int prefix_len = subtype_info - name;
11807 LONGEST L, U;
11808 struct type *type;
108d56a4 11809 const char *bounds_str;
14f9c5c9
AS
11810 int n;
11811
11812 GROW_VECT (name_buf, name_len, prefix_len + 5);
11813 strncpy (name_buf, name, prefix_len);
11814 name_buf[prefix_len] = '\0';
11815
11816 subtype_info += 5;
11817 bounds_str = strchr (subtype_info, '_');
11818 n = 1;
11819
d2e4a39e 11820 if (*subtype_info == 'L')
4c4b4cd2
PH
11821 {
11822 if (!ada_scan_number (bounds_str, n, &L, &n)
11823 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11824 return raw_type;
11825 if (bounds_str[n] == '_')
11826 n += 2;
0963b4bd 11827 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11828 n += 1;
11829 subtype_info += 1;
11830 }
d2e4a39e 11831 else
4c4b4cd2 11832 {
4c4b4cd2 11833 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11834 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11835 {
323e0a4a 11836 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11837 L = 1;
11838 }
11839 }
14f9c5c9 11840
d2e4a39e 11841 if (*subtype_info == 'U')
4c4b4cd2
PH
11842 {
11843 if (!ada_scan_number (bounds_str, n, &U, &n)
11844 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11845 return raw_type;
11846 }
d2e4a39e 11847 else
4c4b4cd2 11848 {
4c4b4cd2 11849 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11850 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11851 {
323e0a4a 11852 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11853 U = L;
11854 }
11855 }
14f9c5c9 11856
0c9c3474
SA
11857 type = create_static_range_type (alloc_type_copy (raw_type),
11858 base_type, L, U);
f5a91472
JB
11859 /* create_static_range_type alters the resulting type's length
11860 to match the size of the base_type, which is not what we want.
11861 Set it back to the original range type's length. */
11862 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11863 TYPE_NAME (type) = name;
14f9c5c9
AS
11864 return type;
11865 }
11866}
11867
4c4b4cd2
PH
11868/* True iff NAME is the name of a range type. */
11869
14f9c5c9 11870int
d2e4a39e 11871ada_is_range_type_name (const char *name)
14f9c5c9
AS
11872{
11873 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11874}
14f9c5c9 11875\f
d2e4a39e 11876
4c4b4cd2
PH
11877 /* Modular types */
11878
11879/* True iff TYPE is an Ada modular type. */
14f9c5c9 11880
14f9c5c9 11881int
d2e4a39e 11882ada_is_modular_type (struct type *type)
14f9c5c9 11883{
18af8284 11884 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11885
11886 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11887 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11888 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11889}
11890
4c4b4cd2
PH
11891/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11892
61ee279c 11893ULONGEST
0056e4d5 11894ada_modulus (struct type *type)
14f9c5c9 11895{
43bbcdc2 11896 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11897}
d2e4a39e 11898\f
f7f9143b
JB
11899
11900/* Ada exception catchpoint support:
11901 ---------------------------------
11902
11903 We support 3 kinds of exception catchpoints:
11904 . catchpoints on Ada exceptions
11905 . catchpoints on unhandled Ada exceptions
11906 . catchpoints on failed assertions
11907
11908 Exceptions raised during failed assertions, or unhandled exceptions
11909 could perfectly be caught with the general catchpoint on Ada exceptions.
11910 However, we can easily differentiate these two special cases, and having
11911 the option to distinguish these two cases from the rest can be useful
11912 to zero-in on certain situations.
11913
11914 Exception catchpoints are a specialized form of breakpoint,
11915 since they rely on inserting breakpoints inside known routines
11916 of the GNAT runtime. The implementation therefore uses a standard
11917 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11918 of breakpoint_ops.
11919
0259addd
JB
11920 Support in the runtime for exception catchpoints have been changed
11921 a few times already, and these changes affect the implementation
11922 of these catchpoints. In order to be able to support several
11923 variants of the runtime, we use a sniffer that will determine
28010a5d 11924 the runtime variant used by the program being debugged. */
f7f9143b 11925
82eacd52
JB
11926/* Ada's standard exceptions.
11927
11928 The Ada 83 standard also defined Numeric_Error. But there so many
11929 situations where it was unclear from the Ada 83 Reference Manual
11930 (RM) whether Constraint_Error or Numeric_Error should be raised,
11931 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11932 Interpretation saying that anytime the RM says that Numeric_Error
11933 should be raised, the implementation may raise Constraint_Error.
11934 Ada 95 went one step further and pretty much removed Numeric_Error
11935 from the list of standard exceptions (it made it a renaming of
11936 Constraint_Error, to help preserve compatibility when compiling
11937 an Ada83 compiler). As such, we do not include Numeric_Error from
11938 this list of standard exceptions. */
3d0b0fa3 11939
a121b7c1 11940static const char *standard_exc[] = {
3d0b0fa3
JB
11941 "constraint_error",
11942 "program_error",
11943 "storage_error",
11944 "tasking_error"
11945};
11946
0259addd
JB
11947typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11948
11949/* A structure that describes how to support exception catchpoints
11950 for a given executable. */
11951
11952struct exception_support_info
11953{
11954 /* The name of the symbol to break on in order to insert
11955 a catchpoint on exceptions. */
11956 const char *catch_exception_sym;
11957
11958 /* The name of the symbol to break on in order to insert
11959 a catchpoint on unhandled exceptions. */
11960 const char *catch_exception_unhandled_sym;
11961
11962 /* The name of the symbol to break on in order to insert
11963 a catchpoint on failed assertions. */
11964 const char *catch_assert_sym;
11965
9f757bf7
XR
11966 /* The name of the symbol to break on in order to insert
11967 a catchpoint on exception handling. */
11968 const char *catch_handlers_sym;
11969
0259addd
JB
11970 /* Assuming that the inferior just triggered an unhandled exception
11971 catchpoint, this function is responsible for returning the address
11972 in inferior memory where the name of that exception is stored.
11973 Return zero if the address could not be computed. */
11974 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11975};
11976
11977static CORE_ADDR ada_unhandled_exception_name_addr (void);
11978static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11979
11980/* The following exception support info structure describes how to
11981 implement exception catchpoints with the latest version of the
11982 Ada runtime (as of 2007-03-06). */
11983
11984static const struct exception_support_info default_exception_support_info =
11985{
11986 "__gnat_debug_raise_exception", /* catch_exception_sym */
11987 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11988 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 11989 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
11990 ada_unhandled_exception_name_addr
11991};
11992
11993/* The following exception support info structure describes how to
11994 implement exception catchpoints with a slightly older version
11995 of the Ada runtime. */
11996
11997static const struct exception_support_info exception_support_info_fallback =
11998{
11999 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12000 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12001 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 12002 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12003 ada_unhandled_exception_name_addr_from_raise
12004};
12005
f17011e0
JB
12006/* Return nonzero if we can detect the exception support routines
12007 described in EINFO.
12008
12009 This function errors out if an abnormal situation is detected
12010 (for instance, if we find the exception support routines, but
12011 that support is found to be incomplete). */
12012
12013static int
12014ada_has_this_exception_support (const struct exception_support_info *einfo)
12015{
12016 struct symbol *sym;
12017
12018 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12019 that should be compiled with debugging information. As a result, we
12020 expect to find that symbol in the symtabs. */
12021
12022 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12023 if (sym == NULL)
a6af7abe
JB
12024 {
12025 /* Perhaps we did not find our symbol because the Ada runtime was
12026 compiled without debugging info, or simply stripped of it.
12027 It happens on some GNU/Linux distributions for instance, where
12028 users have to install a separate debug package in order to get
12029 the runtime's debugging info. In that situation, let the user
12030 know why we cannot insert an Ada exception catchpoint.
12031
12032 Note: Just for the purpose of inserting our Ada exception
12033 catchpoint, we could rely purely on the associated minimal symbol.
12034 But we would be operating in degraded mode anyway, since we are
12035 still lacking the debugging info needed later on to extract
12036 the name of the exception being raised (this name is printed in
12037 the catchpoint message, and is also used when trying to catch
12038 a specific exception). We do not handle this case for now. */
3b7344d5 12039 struct bound_minimal_symbol msym
1c8e84b0
JB
12040 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12041
3b7344d5 12042 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
12043 error (_("Your Ada runtime appears to be missing some debugging "
12044 "information.\nCannot insert Ada exception catchpoint "
12045 "in this configuration."));
12046
12047 return 0;
12048 }
f17011e0
JB
12049
12050 /* Make sure that the symbol we found corresponds to a function. */
12051
12052 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12053 error (_("Symbol \"%s\" is not a function (class = %d)"),
12054 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12055
12056 return 1;
12057}
12058
0259addd
JB
12059/* Inspect the Ada runtime and determine which exception info structure
12060 should be used to provide support for exception catchpoints.
12061
3eecfa55
JB
12062 This function will always set the per-inferior exception_info,
12063 or raise an error. */
0259addd
JB
12064
12065static void
12066ada_exception_support_info_sniffer (void)
12067{
3eecfa55 12068 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
12069
12070 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 12071 if (data->exception_info != NULL)
0259addd
JB
12072 return;
12073
12074 /* Check the latest (default) exception support info. */
f17011e0 12075 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 12076 {
3eecfa55 12077 data->exception_info = &default_exception_support_info;
0259addd
JB
12078 return;
12079 }
12080
12081 /* Try our fallback exception suport info. */
f17011e0 12082 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 12083 {
3eecfa55 12084 data->exception_info = &exception_support_info_fallback;
0259addd
JB
12085 return;
12086 }
12087
12088 /* Sometimes, it is normal for us to not be able to find the routine
12089 we are looking for. This happens when the program is linked with
12090 the shared version of the GNAT runtime, and the program has not been
12091 started yet. Inform the user of these two possible causes if
12092 applicable. */
12093
ccefe4c4 12094 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
12095 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12096
12097 /* If the symbol does not exist, then check that the program is
12098 already started, to make sure that shared libraries have been
12099 loaded. If it is not started, this may mean that the symbol is
12100 in a shared library. */
12101
e99b03dc 12102 if (inferior_ptid.pid () == 0)
0259addd
JB
12103 error (_("Unable to insert catchpoint. Try to start the program first."));
12104
12105 /* At this point, we know that we are debugging an Ada program and
12106 that the inferior has been started, but we still are not able to
0963b4bd 12107 find the run-time symbols. That can mean that we are in
0259addd
JB
12108 configurable run time mode, or that a-except as been optimized
12109 out by the linker... In any case, at this point it is not worth
12110 supporting this feature. */
12111
7dda8cff 12112 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12113}
12114
f7f9143b
JB
12115/* True iff FRAME is very likely to be that of a function that is
12116 part of the runtime system. This is all very heuristic, but is
12117 intended to be used as advice as to what frames are uninteresting
12118 to most users. */
12119
12120static int
12121is_known_support_routine (struct frame_info *frame)
12122{
692465f1 12123 enum language func_lang;
f7f9143b 12124 int i;
f35a17b5 12125 const char *fullname;
f7f9143b 12126
4ed6b5be
JB
12127 /* If this code does not have any debugging information (no symtab),
12128 This cannot be any user code. */
f7f9143b 12129
51abb421 12130 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12131 if (sal.symtab == NULL)
12132 return 1;
12133
4ed6b5be
JB
12134 /* If there is a symtab, but the associated source file cannot be
12135 located, then assume this is not user code: Selecting a frame
12136 for which we cannot display the code would not be very helpful
12137 for the user. This should also take care of case such as VxWorks
12138 where the kernel has some debugging info provided for a few units. */
f7f9143b 12139
f35a17b5
JK
12140 fullname = symtab_to_fullname (sal.symtab);
12141 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12142 return 1;
12143
4ed6b5be
JB
12144 /* Check the unit filename againt the Ada runtime file naming.
12145 We also check the name of the objfile against the name of some
12146 known system libraries that sometimes come with debugging info
12147 too. */
12148
f7f9143b
JB
12149 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12150 {
12151 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12152 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12153 return 1;
eb822aa6
DE
12154 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12155 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12156 return 1;
f7f9143b
JB
12157 }
12158
4ed6b5be 12159 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12160
c6dc63a1
TT
12161 gdb::unique_xmalloc_ptr<char> func_name
12162 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12163 if (func_name == NULL)
12164 return 1;
12165
12166 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12167 {
12168 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12169 if (re_exec (func_name.get ()))
12170 return 1;
f7f9143b
JB
12171 }
12172
12173 return 0;
12174}
12175
12176/* Find the first frame that contains debugging information and that is not
12177 part of the Ada run-time, starting from FI and moving upward. */
12178
0ef643c8 12179void
f7f9143b
JB
12180ada_find_printable_frame (struct frame_info *fi)
12181{
12182 for (; fi != NULL; fi = get_prev_frame (fi))
12183 {
12184 if (!is_known_support_routine (fi))
12185 {
12186 select_frame (fi);
12187 break;
12188 }
12189 }
12190
12191}
12192
12193/* Assuming that the inferior just triggered an unhandled exception
12194 catchpoint, return the address in inferior memory where the name
12195 of the exception is stored.
12196
12197 Return zero if the address could not be computed. */
12198
12199static CORE_ADDR
12200ada_unhandled_exception_name_addr (void)
0259addd
JB
12201{
12202 return parse_and_eval_address ("e.full_name");
12203}
12204
12205/* Same as ada_unhandled_exception_name_addr, except that this function
12206 should be used when the inferior uses an older version of the runtime,
12207 where the exception name needs to be extracted from a specific frame
12208 several frames up in the callstack. */
12209
12210static CORE_ADDR
12211ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12212{
12213 int frame_level;
12214 struct frame_info *fi;
3eecfa55 12215 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12216
12217 /* To determine the name of this exception, we need to select
12218 the frame corresponding to RAISE_SYM_NAME. This frame is
12219 at least 3 levels up, so we simply skip the first 3 frames
12220 without checking the name of their associated function. */
12221 fi = get_current_frame ();
12222 for (frame_level = 0; frame_level < 3; frame_level += 1)
12223 if (fi != NULL)
12224 fi = get_prev_frame (fi);
12225
12226 while (fi != NULL)
12227 {
692465f1
JB
12228 enum language func_lang;
12229
c6dc63a1
TT
12230 gdb::unique_xmalloc_ptr<char> func_name
12231 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12232 if (func_name != NULL)
12233 {
c6dc63a1 12234 if (strcmp (func_name.get (),
55b87a52
KS
12235 data->exception_info->catch_exception_sym) == 0)
12236 break; /* We found the frame we were looking for... */
55b87a52 12237 }
fb44b1a7 12238 fi = get_prev_frame (fi);
f7f9143b
JB
12239 }
12240
12241 if (fi == NULL)
12242 return 0;
12243
12244 select_frame (fi);
12245 return parse_and_eval_address ("id.full_name");
12246}
12247
12248/* Assuming the inferior just triggered an Ada exception catchpoint
12249 (of any type), return the address in inferior memory where the name
12250 of the exception is stored, if applicable.
12251
45db7c09
PA
12252 Assumes the selected frame is the current frame.
12253
f7f9143b
JB
12254 Return zero if the address could not be computed, or if not relevant. */
12255
12256static CORE_ADDR
761269c8 12257ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12258 struct breakpoint *b)
12259{
3eecfa55
JB
12260 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12261
f7f9143b
JB
12262 switch (ex)
12263 {
761269c8 12264 case ada_catch_exception:
f7f9143b
JB
12265 return (parse_and_eval_address ("e.full_name"));
12266 break;
12267
761269c8 12268 case ada_catch_exception_unhandled:
3eecfa55 12269 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12270 break;
9f757bf7
XR
12271
12272 case ada_catch_handlers:
12273 return 0; /* The runtimes does not provide access to the exception
12274 name. */
12275 break;
12276
761269c8 12277 case ada_catch_assert:
f7f9143b
JB
12278 return 0; /* Exception name is not relevant in this case. */
12279 break;
12280
12281 default:
12282 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12283 break;
12284 }
12285
12286 return 0; /* Should never be reached. */
12287}
12288
e547c119
JB
12289/* Assuming the inferior is stopped at an exception catchpoint,
12290 return the message which was associated to the exception, if
12291 available. Return NULL if the message could not be retrieved.
12292
e547c119
JB
12293 Note: The exception message can be associated to an exception
12294 either through the use of the Raise_Exception function, or
12295 more simply (Ada 2005 and later), via:
12296
12297 raise Exception_Name with "exception message";
12298
12299 */
12300
6f46ac85 12301static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12302ada_exception_message_1 (void)
12303{
12304 struct value *e_msg_val;
e547c119 12305 int e_msg_len;
e547c119
JB
12306
12307 /* For runtimes that support this feature, the exception message
12308 is passed as an unbounded string argument called "message". */
12309 e_msg_val = parse_and_eval ("message");
12310 if (e_msg_val == NULL)
12311 return NULL; /* Exception message not supported. */
12312
12313 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12314 gdb_assert (e_msg_val != NULL);
12315 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12316
12317 /* If the message string is empty, then treat it as if there was
12318 no exception message. */
12319 if (e_msg_len <= 0)
12320 return NULL;
12321
6f46ac85
TT
12322 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12323 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12324 e_msg.get ()[e_msg_len] = '\0';
e547c119 12325
e547c119
JB
12326 return e_msg;
12327}
12328
12329/* Same as ada_exception_message_1, except that all exceptions are
12330 contained here (returning NULL instead). */
12331
6f46ac85 12332static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12333ada_exception_message (void)
12334{
6f46ac85 12335 gdb::unique_xmalloc_ptr<char> e_msg;
e547c119
JB
12336
12337 TRY
12338 {
12339 e_msg = ada_exception_message_1 ();
12340 }
12341 CATCH (e, RETURN_MASK_ERROR)
12342 {
6f46ac85 12343 e_msg.reset (nullptr);
e547c119
JB
12344 }
12345 END_CATCH
12346
12347 return e_msg;
12348}
12349
f7f9143b
JB
12350/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12351 any error that ada_exception_name_addr_1 might cause to be thrown.
12352 When an error is intercepted, a warning with the error message is printed,
12353 and zero is returned. */
12354
12355static CORE_ADDR
761269c8 12356ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12357 struct breakpoint *b)
12358{
f7f9143b
JB
12359 CORE_ADDR result = 0;
12360
492d29ea 12361 TRY
f7f9143b
JB
12362 {
12363 result = ada_exception_name_addr_1 (ex, b);
12364 }
12365
492d29ea 12366 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12367 {
12368 warning (_("failed to get exception name: %s"), e.message);
12369 return 0;
12370 }
492d29ea 12371 END_CATCH
f7f9143b
JB
12372
12373 return result;
12374}
12375
cb7de75e 12376static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12377 (const char *excep_string,
12378 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12379
12380/* Ada catchpoints.
12381
12382 In the case of catchpoints on Ada exceptions, the catchpoint will
12383 stop the target on every exception the program throws. When a user
12384 specifies the name of a specific exception, we translate this
12385 request into a condition expression (in text form), and then parse
12386 it into an expression stored in each of the catchpoint's locations.
12387 We then use this condition to check whether the exception that was
12388 raised is the one the user is interested in. If not, then the
12389 target is resumed again. We store the name of the requested
12390 exception, in order to be able to re-set the condition expression
12391 when symbols change. */
12392
12393/* An instance of this type is used to represent an Ada catchpoint
5625a286 12394 breakpoint location. */
28010a5d 12395
5625a286 12396class ada_catchpoint_location : public bp_location
28010a5d 12397{
5625a286
PA
12398public:
12399 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12400 : bp_location (ops, owner)
12401 {}
28010a5d
PA
12402
12403 /* The condition that checks whether the exception that was raised
12404 is the specific exception the user specified on catchpoint
12405 creation. */
4d01a485 12406 expression_up excep_cond_expr;
28010a5d
PA
12407};
12408
12409/* Implement the DTOR method in the bp_location_ops structure for all
12410 Ada exception catchpoint kinds. */
12411
12412static void
12413ada_catchpoint_location_dtor (struct bp_location *bl)
12414{
12415 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12416
4d01a485 12417 al->excep_cond_expr.reset ();
28010a5d
PA
12418}
12419
12420/* The vtable to be used in Ada catchpoint locations. */
12421
12422static const struct bp_location_ops ada_catchpoint_location_ops =
12423{
12424 ada_catchpoint_location_dtor
12425};
12426
c1fc2657 12427/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12428
c1fc2657 12429struct ada_catchpoint : public breakpoint
28010a5d 12430{
28010a5d 12431 /* The name of the specific exception the user specified. */
bc18fbb5 12432 std::string excep_string;
28010a5d
PA
12433};
12434
12435/* Parse the exception condition string in the context of each of the
12436 catchpoint's locations, and store them for later evaluation. */
12437
12438static void
9f757bf7
XR
12439create_excep_cond_exprs (struct ada_catchpoint *c,
12440 enum ada_exception_catchpoint_kind ex)
28010a5d 12441{
28010a5d 12442 struct bp_location *bl;
28010a5d
PA
12443
12444 /* Nothing to do if there's no specific exception to catch. */
bc18fbb5 12445 if (c->excep_string.empty ())
28010a5d
PA
12446 return;
12447
12448 /* Same if there are no locations... */
c1fc2657 12449 if (c->loc == NULL)
28010a5d
PA
12450 return;
12451
12452 /* Compute the condition expression in text form, from the specific
12453 expection we want to catch. */
cb7de75e 12454 std::string cond_string
bc18fbb5 12455 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
28010a5d
PA
12456
12457 /* Iterate over all the catchpoint's locations, and parse an
12458 expression for each. */
c1fc2657 12459 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12460 {
12461 struct ada_catchpoint_location *ada_loc
12462 = (struct ada_catchpoint_location *) bl;
4d01a485 12463 expression_up exp;
28010a5d
PA
12464
12465 if (!bl->shlib_disabled)
12466 {
bbc13ae3 12467 const char *s;
28010a5d 12468
cb7de75e 12469 s = cond_string.c_str ();
492d29ea 12470 TRY
28010a5d 12471 {
036e657b
JB
12472 exp = parse_exp_1 (&s, bl->address,
12473 block_for_pc (bl->address),
12474 0);
28010a5d 12475 }
492d29ea 12476 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12477 {
12478 warning (_("failed to reevaluate internal exception condition "
12479 "for catchpoint %d: %s"),
c1fc2657 12480 c->number, e.message);
849f2b52 12481 }
492d29ea 12482 END_CATCH
28010a5d
PA
12483 }
12484
b22e99fd 12485 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12486 }
28010a5d
PA
12487}
12488
28010a5d
PA
12489/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12490 structure for all exception catchpoint kinds. */
12491
12492static struct bp_location *
761269c8 12493allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12494 struct breakpoint *self)
12495{
5625a286 12496 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12497}
12498
12499/* Implement the RE_SET method in the breakpoint_ops structure for all
12500 exception catchpoint kinds. */
12501
12502static void
761269c8 12503re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12504{
12505 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12506
12507 /* Call the base class's method. This updates the catchpoint's
12508 locations. */
2060206e 12509 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12510
12511 /* Reparse the exception conditional expressions. One for each
12512 location. */
9f757bf7 12513 create_excep_cond_exprs (c, ex);
28010a5d
PA
12514}
12515
12516/* Returns true if we should stop for this breakpoint hit. If the
12517 user specified a specific exception, we only want to cause a stop
12518 if the program thrown that exception. */
12519
12520static int
12521should_stop_exception (const struct bp_location *bl)
12522{
12523 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12524 const struct ada_catchpoint_location *ada_loc
12525 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12526 int stop;
12527
12528 /* With no specific exception, should always stop. */
bc18fbb5 12529 if (c->excep_string.empty ())
28010a5d
PA
12530 return 1;
12531
12532 if (ada_loc->excep_cond_expr == NULL)
12533 {
12534 /* We will have a NULL expression if back when we were creating
12535 the expressions, this location's had failed to parse. */
12536 return 1;
12537 }
12538
12539 stop = 1;
492d29ea 12540 TRY
28010a5d
PA
12541 {
12542 struct value *mark;
12543
12544 mark = value_mark ();
4d01a485 12545 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12546 value_free_to_mark (mark);
12547 }
492d29ea
PA
12548 CATCH (ex, RETURN_MASK_ALL)
12549 {
12550 exception_fprintf (gdb_stderr, ex,
12551 _("Error in testing exception condition:\n"));
12552 }
12553 END_CATCH
12554
28010a5d
PA
12555 return stop;
12556}
12557
12558/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12559 for all exception catchpoint kinds. */
12560
12561static void
761269c8 12562check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12563{
12564 bs->stop = should_stop_exception (bs->bp_location_at);
12565}
12566
f7f9143b
JB
12567/* Implement the PRINT_IT method in the breakpoint_ops structure
12568 for all exception catchpoint kinds. */
12569
12570static enum print_stop_action
761269c8 12571print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12572{
79a45e25 12573 struct ui_out *uiout = current_uiout;
348d480f
PA
12574 struct breakpoint *b = bs->breakpoint_at;
12575
956a9fb9 12576 annotate_catchpoint (b->number);
f7f9143b 12577
112e8700 12578 if (uiout->is_mi_like_p ())
f7f9143b 12579 {
112e8700 12580 uiout->field_string ("reason",
956a9fb9 12581 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12582 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12583 }
12584
112e8700
SM
12585 uiout->text (b->disposition == disp_del
12586 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12587 uiout->field_int ("bkptno", b->number);
12588 uiout->text (", ");
f7f9143b 12589
45db7c09
PA
12590 /* ada_exception_name_addr relies on the selected frame being the
12591 current frame. Need to do this here because this function may be
12592 called more than once when printing a stop, and below, we'll
12593 select the first frame past the Ada run-time (see
12594 ada_find_printable_frame). */
12595 select_frame (get_current_frame ());
12596
f7f9143b
JB
12597 switch (ex)
12598 {
761269c8
JB
12599 case ada_catch_exception:
12600 case ada_catch_exception_unhandled:
9f757bf7 12601 case ada_catch_handlers:
956a9fb9
JB
12602 {
12603 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12604 char exception_name[256];
12605
12606 if (addr != 0)
12607 {
c714b426
PA
12608 read_memory (addr, (gdb_byte *) exception_name,
12609 sizeof (exception_name) - 1);
956a9fb9
JB
12610 exception_name [sizeof (exception_name) - 1] = '\0';
12611 }
12612 else
12613 {
12614 /* For some reason, we were unable to read the exception
12615 name. This could happen if the Runtime was compiled
12616 without debugging info, for instance. In that case,
12617 just replace the exception name by the generic string
12618 "exception" - it will read as "an exception" in the
12619 notification we are about to print. */
967cff16 12620 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12621 }
12622 /* In the case of unhandled exception breakpoints, we print
12623 the exception name as "unhandled EXCEPTION_NAME", to make
12624 it clearer to the user which kind of catchpoint just got
12625 hit. We used ui_out_text to make sure that this extra
12626 info does not pollute the exception name in the MI case. */
761269c8 12627 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12628 uiout->text ("unhandled ");
12629 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12630 }
12631 break;
761269c8 12632 case ada_catch_assert:
956a9fb9
JB
12633 /* In this case, the name of the exception is not really
12634 important. Just print "failed assertion" to make it clearer
12635 that his program just hit an assertion-failure catchpoint.
12636 We used ui_out_text because this info does not belong in
12637 the MI output. */
112e8700 12638 uiout->text ("failed assertion");
956a9fb9 12639 break;
f7f9143b 12640 }
e547c119 12641
6f46ac85 12642 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
e547c119
JB
12643 if (exception_message != NULL)
12644 {
e547c119 12645 uiout->text (" (");
6f46ac85 12646 uiout->field_string ("exception-message", exception_message.get ());
e547c119 12647 uiout->text (")");
e547c119
JB
12648 }
12649
112e8700 12650 uiout->text (" at ");
956a9fb9 12651 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12652
12653 return PRINT_SRC_AND_LOC;
12654}
12655
12656/* Implement the PRINT_ONE method in the breakpoint_ops structure
12657 for all exception catchpoint kinds. */
12658
12659static void
761269c8 12660print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12661 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12662{
79a45e25 12663 struct ui_out *uiout = current_uiout;
28010a5d 12664 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12665 struct value_print_options opts;
12666
12667 get_user_print_options (&opts);
12668 if (opts.addressprint)
f7f9143b
JB
12669 {
12670 annotate_field (4);
112e8700 12671 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12672 }
12673
12674 annotate_field (5);
a6d9a66e 12675 *last_loc = b->loc;
f7f9143b
JB
12676 switch (ex)
12677 {
761269c8 12678 case ada_catch_exception:
bc18fbb5 12679 if (!c->excep_string.empty ())
f7f9143b 12680 {
bc18fbb5
TT
12681 std::string msg = string_printf (_("`%s' Ada exception"),
12682 c->excep_string.c_str ());
28010a5d 12683
112e8700 12684 uiout->field_string ("what", msg);
f7f9143b
JB
12685 }
12686 else
112e8700 12687 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12688
12689 break;
12690
761269c8 12691 case ada_catch_exception_unhandled:
112e8700 12692 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12693 break;
12694
9f757bf7 12695 case ada_catch_handlers:
bc18fbb5 12696 if (!c->excep_string.empty ())
9f757bf7
XR
12697 {
12698 uiout->field_fmt ("what",
12699 _("`%s' Ada exception handlers"),
bc18fbb5 12700 c->excep_string.c_str ());
9f757bf7
XR
12701 }
12702 else
12703 uiout->field_string ("what", "all Ada exceptions handlers");
12704 break;
12705
761269c8 12706 case ada_catch_assert:
112e8700 12707 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12708 break;
12709
12710 default:
12711 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12712 break;
12713 }
12714}
12715
12716/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12717 for all exception catchpoint kinds. */
12718
12719static void
761269c8 12720print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12721 struct breakpoint *b)
12722{
28010a5d 12723 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12724 struct ui_out *uiout = current_uiout;
28010a5d 12725
112e8700 12726 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12727 : _("Catchpoint "));
112e8700
SM
12728 uiout->field_int ("bkptno", b->number);
12729 uiout->text (": ");
00eb2c4a 12730
f7f9143b
JB
12731 switch (ex)
12732 {
761269c8 12733 case ada_catch_exception:
bc18fbb5 12734 if (!c->excep_string.empty ())
00eb2c4a 12735 {
862d101a 12736 std::string info = string_printf (_("`%s' Ada exception"),
bc18fbb5 12737 c->excep_string.c_str ());
862d101a 12738 uiout->text (info.c_str ());
00eb2c4a 12739 }
f7f9143b 12740 else
112e8700 12741 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12742 break;
12743
761269c8 12744 case ada_catch_exception_unhandled:
112e8700 12745 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12746 break;
9f757bf7
XR
12747
12748 case ada_catch_handlers:
bc18fbb5 12749 if (!c->excep_string.empty ())
9f757bf7
XR
12750 {
12751 std::string info
12752 = string_printf (_("`%s' Ada exception handlers"),
bc18fbb5 12753 c->excep_string.c_str ());
9f757bf7
XR
12754 uiout->text (info.c_str ());
12755 }
12756 else
12757 uiout->text (_("all Ada exceptions handlers"));
12758 break;
12759
761269c8 12760 case ada_catch_assert:
112e8700 12761 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12762 break;
12763
12764 default:
12765 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12766 break;
12767 }
12768}
12769
6149aea9
PA
12770/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12771 for all exception catchpoint kinds. */
12772
12773static void
761269c8 12774print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12775 struct breakpoint *b, struct ui_file *fp)
12776{
28010a5d
PA
12777 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12778
6149aea9
PA
12779 switch (ex)
12780 {
761269c8 12781 case ada_catch_exception:
6149aea9 12782 fprintf_filtered (fp, "catch exception");
bc18fbb5
TT
12783 if (!c->excep_string.empty ())
12784 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
6149aea9
PA
12785 break;
12786
761269c8 12787 case ada_catch_exception_unhandled:
78076abc 12788 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12789 break;
12790
9f757bf7
XR
12791 case ada_catch_handlers:
12792 fprintf_filtered (fp, "catch handlers");
12793 break;
12794
761269c8 12795 case ada_catch_assert:
6149aea9
PA
12796 fprintf_filtered (fp, "catch assert");
12797 break;
12798
12799 default:
12800 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12801 }
d9b3f62e 12802 print_recreate_thread (b, fp);
6149aea9
PA
12803}
12804
f7f9143b
JB
12805/* Virtual table for "catch exception" breakpoints. */
12806
28010a5d
PA
12807static struct bp_location *
12808allocate_location_catch_exception (struct breakpoint *self)
12809{
761269c8 12810 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12811}
12812
12813static void
12814re_set_catch_exception (struct breakpoint *b)
12815{
761269c8 12816 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12817}
12818
12819static void
12820check_status_catch_exception (bpstat bs)
12821{
761269c8 12822 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12823}
12824
f7f9143b 12825static enum print_stop_action
348d480f 12826print_it_catch_exception (bpstat bs)
f7f9143b 12827{
761269c8 12828 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12829}
12830
12831static void
a6d9a66e 12832print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12833{
761269c8 12834 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12835}
12836
12837static void
12838print_mention_catch_exception (struct breakpoint *b)
12839{
761269c8 12840 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12841}
12842
6149aea9
PA
12843static void
12844print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12845{
761269c8 12846 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12847}
12848
2060206e 12849static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12850
12851/* Virtual table for "catch exception unhandled" breakpoints. */
12852
28010a5d
PA
12853static struct bp_location *
12854allocate_location_catch_exception_unhandled (struct breakpoint *self)
12855{
761269c8 12856 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12857}
12858
12859static void
12860re_set_catch_exception_unhandled (struct breakpoint *b)
12861{
761269c8 12862 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12863}
12864
12865static void
12866check_status_catch_exception_unhandled (bpstat bs)
12867{
761269c8 12868 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12869}
12870
f7f9143b 12871static enum print_stop_action
348d480f 12872print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12873{
761269c8 12874 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12875}
12876
12877static void
a6d9a66e
UW
12878print_one_catch_exception_unhandled (struct breakpoint *b,
12879 struct bp_location **last_loc)
f7f9143b 12880{
761269c8 12881 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12882}
12883
12884static void
12885print_mention_catch_exception_unhandled (struct breakpoint *b)
12886{
761269c8 12887 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12888}
12889
6149aea9
PA
12890static void
12891print_recreate_catch_exception_unhandled (struct breakpoint *b,
12892 struct ui_file *fp)
12893{
761269c8 12894 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12895}
12896
2060206e 12897static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12898
12899/* Virtual table for "catch assert" breakpoints. */
12900
28010a5d
PA
12901static struct bp_location *
12902allocate_location_catch_assert (struct breakpoint *self)
12903{
761269c8 12904 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12905}
12906
12907static void
12908re_set_catch_assert (struct breakpoint *b)
12909{
761269c8 12910 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12911}
12912
12913static void
12914check_status_catch_assert (bpstat bs)
12915{
761269c8 12916 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12917}
12918
f7f9143b 12919static enum print_stop_action
348d480f 12920print_it_catch_assert (bpstat bs)
f7f9143b 12921{
761269c8 12922 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12923}
12924
12925static void
a6d9a66e 12926print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12927{
761269c8 12928 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12929}
12930
12931static void
12932print_mention_catch_assert (struct breakpoint *b)
12933{
761269c8 12934 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12935}
12936
6149aea9
PA
12937static void
12938print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12939{
761269c8 12940 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12941}
12942
2060206e 12943static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12944
9f757bf7
XR
12945/* Virtual table for "catch handlers" breakpoints. */
12946
12947static struct bp_location *
12948allocate_location_catch_handlers (struct breakpoint *self)
12949{
12950 return allocate_location_exception (ada_catch_handlers, self);
12951}
12952
12953static void
12954re_set_catch_handlers (struct breakpoint *b)
12955{
12956 re_set_exception (ada_catch_handlers, b);
12957}
12958
12959static void
12960check_status_catch_handlers (bpstat bs)
12961{
12962 check_status_exception (ada_catch_handlers, bs);
12963}
12964
12965static enum print_stop_action
12966print_it_catch_handlers (bpstat bs)
12967{
12968 return print_it_exception (ada_catch_handlers, bs);
12969}
12970
12971static void
12972print_one_catch_handlers (struct breakpoint *b,
12973 struct bp_location **last_loc)
12974{
12975 print_one_exception (ada_catch_handlers, b, last_loc);
12976}
12977
12978static void
12979print_mention_catch_handlers (struct breakpoint *b)
12980{
12981 print_mention_exception (ada_catch_handlers, b);
12982}
12983
12984static void
12985print_recreate_catch_handlers (struct breakpoint *b,
12986 struct ui_file *fp)
12987{
12988 print_recreate_exception (ada_catch_handlers, b, fp);
12989}
12990
12991static struct breakpoint_ops catch_handlers_breakpoint_ops;
12992
f7f9143b
JB
12993/* Split the arguments specified in a "catch exception" command.
12994 Set EX to the appropriate catchpoint type.
28010a5d 12995 Set EXCEP_STRING to the name of the specific exception if
5845583d 12996 specified by the user.
9f757bf7
XR
12997 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12998 "catch handlers" command. False otherwise.
5845583d
JB
12999 If a condition is found at the end of the arguments, the condition
13000 expression is stored in COND_STRING (memory must be deallocated
13001 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
13002
13003static void
a121b7c1 13004catch_ada_exception_command_split (const char *args,
9f757bf7 13005 bool is_catch_handlers_cmd,
761269c8 13006 enum ada_exception_catchpoint_kind *ex,
bc18fbb5
TT
13007 std::string *excep_string,
13008 std::string *cond_string)
f7f9143b 13009{
bc18fbb5 13010 std::string exception_name;
f7f9143b 13011
bc18fbb5
TT
13012 exception_name = extract_arg (&args);
13013 if (exception_name == "if")
5845583d
JB
13014 {
13015 /* This is not an exception name; this is the start of a condition
13016 expression for a catchpoint on all exceptions. So, "un-get"
13017 this token, and set exception_name to NULL. */
bc18fbb5 13018 exception_name.clear ();
5845583d
JB
13019 args -= 2;
13020 }
f7f9143b 13021
5845583d 13022 /* Check to see if we have a condition. */
f7f9143b 13023
f1735a53 13024 args = skip_spaces (args);
61012eef 13025 if (startswith (args, "if")
5845583d
JB
13026 && (isspace (args[2]) || args[2] == '\0'))
13027 {
13028 args += 2;
f1735a53 13029 args = skip_spaces (args);
5845583d
JB
13030
13031 if (args[0] == '\0')
13032 error (_("Condition missing after `if' keyword"));
bc18fbb5 13033 *cond_string = args;
5845583d
JB
13034
13035 args += strlen (args);
13036 }
13037
13038 /* Check that we do not have any more arguments. Anything else
13039 is unexpected. */
f7f9143b
JB
13040
13041 if (args[0] != '\0')
13042 error (_("Junk at end of expression"));
13043
9f757bf7
XR
13044 if (is_catch_handlers_cmd)
13045 {
13046 /* Catch handling of exceptions. */
13047 *ex = ada_catch_handlers;
13048 *excep_string = exception_name;
13049 }
bc18fbb5 13050 else if (exception_name.empty ())
f7f9143b
JB
13051 {
13052 /* Catch all exceptions. */
761269c8 13053 *ex = ada_catch_exception;
bc18fbb5 13054 excep_string->clear ();
f7f9143b 13055 }
bc18fbb5 13056 else if (exception_name == "unhandled")
f7f9143b
JB
13057 {
13058 /* Catch unhandled exceptions. */
761269c8 13059 *ex = ada_catch_exception_unhandled;
bc18fbb5 13060 excep_string->clear ();
f7f9143b
JB
13061 }
13062 else
13063 {
13064 /* Catch a specific exception. */
761269c8 13065 *ex = ada_catch_exception;
28010a5d 13066 *excep_string = exception_name;
f7f9143b
JB
13067 }
13068}
13069
13070/* Return the name of the symbol on which we should break in order to
13071 implement a catchpoint of the EX kind. */
13072
13073static const char *
761269c8 13074ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 13075{
3eecfa55
JB
13076 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13077
13078 gdb_assert (data->exception_info != NULL);
0259addd 13079
f7f9143b
JB
13080 switch (ex)
13081 {
761269c8 13082 case ada_catch_exception:
3eecfa55 13083 return (data->exception_info->catch_exception_sym);
f7f9143b 13084 break;
761269c8 13085 case ada_catch_exception_unhandled:
3eecfa55 13086 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 13087 break;
761269c8 13088 case ada_catch_assert:
3eecfa55 13089 return (data->exception_info->catch_assert_sym);
f7f9143b 13090 break;
9f757bf7
XR
13091 case ada_catch_handlers:
13092 return (data->exception_info->catch_handlers_sym);
13093 break;
f7f9143b
JB
13094 default:
13095 internal_error (__FILE__, __LINE__,
13096 _("unexpected catchpoint kind (%d)"), ex);
13097 }
13098}
13099
13100/* Return the breakpoint ops "virtual table" used for catchpoints
13101 of the EX kind. */
13102
c0a91b2b 13103static const struct breakpoint_ops *
761269c8 13104ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
13105{
13106 switch (ex)
13107 {
761269c8 13108 case ada_catch_exception:
f7f9143b
JB
13109 return (&catch_exception_breakpoint_ops);
13110 break;
761269c8 13111 case ada_catch_exception_unhandled:
f7f9143b
JB
13112 return (&catch_exception_unhandled_breakpoint_ops);
13113 break;
761269c8 13114 case ada_catch_assert:
f7f9143b
JB
13115 return (&catch_assert_breakpoint_ops);
13116 break;
9f757bf7
XR
13117 case ada_catch_handlers:
13118 return (&catch_handlers_breakpoint_ops);
13119 break;
f7f9143b
JB
13120 default:
13121 internal_error (__FILE__, __LINE__,
13122 _("unexpected catchpoint kind (%d)"), ex);
13123 }
13124}
13125
13126/* Return the condition that will be used to match the current exception
13127 being raised with the exception that the user wants to catch. This
13128 assumes that this condition is used when the inferior just triggered
13129 an exception catchpoint.
cb7de75e 13130 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 13131
cb7de75e 13132static std::string
9f757bf7
XR
13133ada_exception_catchpoint_cond_string (const char *excep_string,
13134 enum ada_exception_catchpoint_kind ex)
f7f9143b 13135{
3d0b0fa3 13136 int i;
9f757bf7 13137 bool is_standard_exc = false;
cb7de75e 13138 std::string result;
9f757bf7
XR
13139
13140 if (ex == ada_catch_handlers)
13141 {
13142 /* For exception handlers catchpoints, the condition string does
13143 not use the same parameter as for the other exceptions. */
cb7de75e
TT
13144 result = ("long_integer (GNAT_GCC_exception_Access"
13145 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13146 }
13147 else
cb7de75e 13148 result = "long_integer (e)";
3d0b0fa3 13149
0963b4bd 13150 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13151 runtime units that have been compiled without debugging info; if
28010a5d 13152 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13153 exception (e.g. "constraint_error") then, during the evaluation
13154 of the condition expression, the symbol lookup on this name would
0963b4bd 13155 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13156 may then be set only on user-defined exceptions which have the
13157 same not-fully-qualified name (e.g. my_package.constraint_error).
13158
13159 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13160 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13161 exception constraint_error" is rewritten into "catch exception
13162 standard.constraint_error".
13163
13164 If an exception named contraint_error is defined in another package of
13165 the inferior program, then the only way to specify this exception as a
13166 breakpoint condition is to use its fully-qualified named:
13167 e.g. my_package.constraint_error. */
13168
13169 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13170 {
28010a5d 13171 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13172 {
9f757bf7
XR
13173 is_standard_exc = true;
13174 break;
3d0b0fa3
JB
13175 }
13176 }
9f757bf7 13177
cb7de75e
TT
13178 result += " = ";
13179
9f757bf7 13180 if (is_standard_exc)
cb7de75e 13181 string_appendf (result, "long_integer (&standard.%s)", excep_string);
9f757bf7 13182 else
cb7de75e 13183 string_appendf (result, "long_integer (&%s)", excep_string);
9f757bf7 13184
9f757bf7 13185 return result;
f7f9143b
JB
13186}
13187
13188/* Return the symtab_and_line that should be used to insert an exception
13189 catchpoint of the TYPE kind.
13190
28010a5d
PA
13191 ADDR_STRING returns the name of the function where the real
13192 breakpoint that implements the catchpoints is set, depending on the
13193 type of catchpoint we need to create. */
f7f9143b
JB
13194
13195static struct symtab_and_line
bc18fbb5 13196ada_exception_sal (enum ada_exception_catchpoint_kind ex,
f2fc3015 13197 const char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13198{
13199 const char *sym_name;
13200 struct symbol *sym;
f7f9143b 13201
0259addd
JB
13202 /* First, find out which exception support info to use. */
13203 ada_exception_support_info_sniffer ();
13204
13205 /* Then lookup the function on which we will break in order to catch
f7f9143b 13206 the Ada exceptions requested by the user. */
f7f9143b
JB
13207 sym_name = ada_exception_sym_name (ex);
13208 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13209
57aff202
JB
13210 if (sym == NULL)
13211 error (_("Catchpoint symbol not found: %s"), sym_name);
13212
13213 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13214 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
f7f9143b
JB
13215
13216 /* Set ADDR_STRING. */
f7f9143b
JB
13217 *addr_string = xstrdup (sym_name);
13218
f7f9143b 13219 /* Set OPS. */
4b9eee8c 13220 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13221
f17011e0 13222 return find_function_start_sal (sym, 1);
f7f9143b
JB
13223}
13224
b4a5b78b 13225/* Create an Ada exception catchpoint.
f7f9143b 13226
b4a5b78b 13227 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13228
bc18fbb5 13229 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
2df4d1d5 13230 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
bc18fbb5 13231 of the exception to which this catchpoint applies.
2df4d1d5 13232
bc18fbb5 13233 COND_STRING, if not empty, is the catchpoint condition.
f7f9143b 13234
b4a5b78b
JB
13235 TEMPFLAG, if nonzero, means that the underlying breakpoint
13236 should be temporary.
28010a5d 13237
b4a5b78b 13238 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13239
349774ef 13240void
28010a5d 13241create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13242 enum ada_exception_catchpoint_kind ex_kind,
bc18fbb5 13243 const std::string &excep_string,
56ecd069 13244 const std::string &cond_string,
28010a5d 13245 int tempflag,
349774ef 13246 int disabled,
28010a5d
PA
13247 int from_tty)
13248{
f2fc3015 13249 const char *addr_string = NULL;
b4a5b78b 13250 const struct breakpoint_ops *ops = NULL;
bc18fbb5 13251 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
28010a5d 13252
b270e6f9
TT
13253 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13254 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
349774ef 13255 ops, tempflag, disabled, from_tty);
28010a5d 13256 c->excep_string = excep_string;
9f757bf7 13257 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13258 if (!cond_string.empty ())
13259 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13260 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13261}
13262
9ac4176b
PA
13263/* Implement the "catch exception" command. */
13264
13265static void
eb4c3f4a 13266catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13267 struct cmd_list_element *command)
13268{
a121b7c1 13269 const char *arg = arg_entry;
9ac4176b
PA
13270 struct gdbarch *gdbarch = get_current_arch ();
13271 int tempflag;
761269c8 13272 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13273 std::string excep_string;
56ecd069 13274 std::string cond_string;
9ac4176b
PA
13275
13276 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13277
13278 if (!arg)
13279 arg = "";
9f757bf7 13280 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
bc18fbb5 13281 &cond_string);
9f757bf7
XR
13282 create_ada_exception_catchpoint (gdbarch, ex_kind,
13283 excep_string, cond_string,
13284 tempflag, 1 /* enabled */,
13285 from_tty);
13286}
13287
13288/* Implement the "catch handlers" command. */
13289
13290static void
13291catch_ada_handlers_command (const char *arg_entry, int from_tty,
13292 struct cmd_list_element *command)
13293{
13294 const char *arg = arg_entry;
13295 struct gdbarch *gdbarch = get_current_arch ();
13296 int tempflag;
13297 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13298 std::string excep_string;
56ecd069 13299 std::string cond_string;
9f757bf7
XR
13300
13301 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13302
13303 if (!arg)
13304 arg = "";
13305 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
bc18fbb5 13306 &cond_string);
b4a5b78b
JB
13307 create_ada_exception_catchpoint (gdbarch, ex_kind,
13308 excep_string, cond_string,
349774ef
JB
13309 tempflag, 1 /* enabled */,
13310 from_tty);
9ac4176b
PA
13311}
13312
b4a5b78b 13313/* Split the arguments specified in a "catch assert" command.
5845583d 13314
b4a5b78b
JB
13315 ARGS contains the command's arguments (or the empty string if
13316 no arguments were passed).
5845583d
JB
13317
13318 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13319 (the memory needs to be deallocated after use). */
5845583d 13320
b4a5b78b 13321static void
56ecd069 13322catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13323{
f1735a53 13324 args = skip_spaces (args);
f7f9143b 13325
5845583d 13326 /* Check whether a condition was provided. */
61012eef 13327 if (startswith (args, "if")
5845583d 13328 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13329 {
5845583d 13330 args += 2;
f1735a53 13331 args = skip_spaces (args);
5845583d
JB
13332 if (args[0] == '\0')
13333 error (_("condition missing after `if' keyword"));
56ecd069 13334 cond_string.assign (args);
f7f9143b
JB
13335 }
13336
5845583d
JB
13337 /* Otherwise, there should be no other argument at the end of
13338 the command. */
13339 else if (args[0] != '\0')
13340 error (_("Junk at end of arguments."));
f7f9143b
JB
13341}
13342
9ac4176b
PA
13343/* Implement the "catch assert" command. */
13344
13345static void
eb4c3f4a 13346catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13347 struct cmd_list_element *command)
13348{
a121b7c1 13349 const char *arg = arg_entry;
9ac4176b
PA
13350 struct gdbarch *gdbarch = get_current_arch ();
13351 int tempflag;
56ecd069 13352 std::string cond_string;
9ac4176b
PA
13353
13354 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13355
13356 if (!arg)
13357 arg = "";
56ecd069 13358 catch_ada_assert_command_split (arg, cond_string);
761269c8 13359 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
241db429 13360 "", cond_string,
349774ef
JB
13361 tempflag, 1 /* enabled */,
13362 from_tty);
9ac4176b 13363}
778865d3
JB
13364
13365/* Return non-zero if the symbol SYM is an Ada exception object. */
13366
13367static int
13368ada_is_exception_sym (struct symbol *sym)
13369{
a737d952 13370 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
778865d3
JB
13371
13372 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13373 && SYMBOL_CLASS (sym) != LOC_BLOCK
13374 && SYMBOL_CLASS (sym) != LOC_CONST
13375 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13376 && type_name != NULL && strcmp (type_name, "exception") == 0);
13377}
13378
13379/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13380 Ada exception object. This matches all exceptions except the ones
13381 defined by the Ada language. */
13382
13383static int
13384ada_is_non_standard_exception_sym (struct symbol *sym)
13385{
13386 int i;
13387
13388 if (!ada_is_exception_sym (sym))
13389 return 0;
13390
13391 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13392 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13393 return 0; /* A standard exception. */
13394
13395 /* Numeric_Error is also a standard exception, so exclude it.
13396 See the STANDARD_EXC description for more details as to why
13397 this exception is not listed in that array. */
13398 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13399 return 0;
13400
13401 return 1;
13402}
13403
ab816a27 13404/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13405 objects.
13406
13407 The comparison is determined first by exception name, and then
13408 by exception address. */
13409
ab816a27 13410bool
cc536b21 13411ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13412{
778865d3
JB
13413 int result;
13414
ab816a27
TT
13415 result = strcmp (name, other.name);
13416 if (result < 0)
13417 return true;
13418 if (result == 0 && addr < other.addr)
13419 return true;
13420 return false;
13421}
778865d3 13422
ab816a27 13423bool
cc536b21 13424ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13425{
13426 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13427}
13428
13429/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13430 routine, but keeping the first SKIP elements untouched.
13431
13432 All duplicates are also removed. */
13433
13434static void
ab816a27 13435sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13436 int skip)
13437{
ab816a27
TT
13438 std::sort (exceptions->begin () + skip, exceptions->end ());
13439 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13440 exceptions->end ());
778865d3
JB
13441}
13442
778865d3
JB
13443/* Add all exceptions defined by the Ada standard whose name match
13444 a regular expression.
13445
13446 If PREG is not NULL, then this regexp_t object is used to
13447 perform the symbol name matching. Otherwise, no name-based
13448 filtering is performed.
13449
13450 EXCEPTIONS is a vector of exceptions to which matching exceptions
13451 gets pushed. */
13452
13453static void
2d7cc5c7 13454ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13455 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13456{
13457 int i;
13458
13459 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13460 {
13461 if (preg == NULL
2d7cc5c7 13462 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13463 {
13464 struct bound_minimal_symbol msymbol
13465 = ada_lookup_simple_minsym (standard_exc[i]);
13466
13467 if (msymbol.minsym != NULL)
13468 {
13469 struct ada_exc_info info
77e371c0 13470 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13471
ab816a27 13472 exceptions->push_back (info);
778865d3
JB
13473 }
13474 }
13475 }
13476}
13477
13478/* Add all Ada exceptions defined locally and accessible from the given
13479 FRAME.
13480
13481 If PREG is not NULL, then this regexp_t object is used to
13482 perform the symbol name matching. Otherwise, no name-based
13483 filtering is performed.
13484
13485 EXCEPTIONS is a vector of exceptions to which matching exceptions
13486 gets pushed. */
13487
13488static void
2d7cc5c7
PA
13489ada_add_exceptions_from_frame (compiled_regex *preg,
13490 struct frame_info *frame,
ab816a27 13491 std::vector<ada_exc_info> *exceptions)
778865d3 13492{
3977b71f 13493 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13494
13495 while (block != 0)
13496 {
13497 struct block_iterator iter;
13498 struct symbol *sym;
13499
13500 ALL_BLOCK_SYMBOLS (block, iter, sym)
13501 {
13502 switch (SYMBOL_CLASS (sym))
13503 {
13504 case LOC_TYPEDEF:
13505 case LOC_BLOCK:
13506 case LOC_CONST:
13507 break;
13508 default:
13509 if (ada_is_exception_sym (sym))
13510 {
13511 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13512 SYMBOL_VALUE_ADDRESS (sym)};
13513
ab816a27 13514 exceptions->push_back (info);
778865d3
JB
13515 }
13516 }
13517 }
13518 if (BLOCK_FUNCTION (block) != NULL)
13519 break;
13520 block = BLOCK_SUPERBLOCK (block);
13521 }
13522}
13523
14bc53a8
PA
13524/* Return true if NAME matches PREG or if PREG is NULL. */
13525
13526static bool
2d7cc5c7 13527name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13528{
13529 return (preg == NULL
2d7cc5c7 13530 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13531}
13532
778865d3
JB
13533/* Add all exceptions defined globally whose name name match
13534 a regular expression, excluding standard exceptions.
13535
13536 The reason we exclude standard exceptions is that they need
13537 to be handled separately: Standard exceptions are defined inside
13538 a runtime unit which is normally not compiled with debugging info,
13539 and thus usually do not show up in our symbol search. However,
13540 if the unit was in fact built with debugging info, we need to
13541 exclude them because they would duplicate the entry we found
13542 during the special loop that specifically searches for those
13543 standard exceptions.
13544
13545 If PREG is not NULL, then this regexp_t object is used to
13546 perform the symbol name matching. Otherwise, no name-based
13547 filtering is performed.
13548
13549 EXCEPTIONS is a vector of exceptions to which matching exceptions
13550 gets pushed. */
13551
13552static void
2d7cc5c7 13553ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13554 std::vector<ada_exc_info> *exceptions)
778865d3 13555{
14bc53a8
PA
13556 /* In Ada, the symbol "search name" is a linkage name, whereas the
13557 regular expression used to do the matching refers to the natural
13558 name. So match against the decoded name. */
13559 expand_symtabs_matching (NULL,
b5ec771e 13560 lookup_name_info::match_any (),
14bc53a8
PA
13561 [&] (const char *search_name)
13562 {
13563 const char *decoded = ada_decode (search_name);
13564 return name_matches_regex (decoded, preg);
13565 },
13566 NULL,
13567 VARIABLES_DOMAIN);
778865d3 13568
2030c079 13569 for (objfile *objfile : current_program_space->objfiles ())
778865d3 13570 {
d8aeb77f 13571 for (compunit_symtab *s : objfile_compunits (objfile))
778865d3 13572 {
d8aeb77f
TT
13573 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13574 int i;
778865d3 13575
d8aeb77f
TT
13576 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13577 {
13578 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13579 struct block_iterator iter;
13580 struct symbol *sym;
778865d3 13581
d8aeb77f
TT
13582 ALL_BLOCK_SYMBOLS (b, iter, sym)
13583 if (ada_is_non_standard_exception_sym (sym)
13584 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13585 {
13586 struct ada_exc_info info
13587 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13588
13589 exceptions->push_back (info);
13590 }
13591 }
778865d3
JB
13592 }
13593 }
13594}
13595
13596/* Implements ada_exceptions_list with the regular expression passed
13597 as a regex_t, rather than a string.
13598
13599 If not NULL, PREG is used to filter out exceptions whose names
13600 do not match. Otherwise, all exceptions are listed. */
13601
ab816a27 13602static std::vector<ada_exc_info>
2d7cc5c7 13603ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13604{
ab816a27 13605 std::vector<ada_exc_info> result;
778865d3
JB
13606 int prev_len;
13607
13608 /* First, list the known standard exceptions. These exceptions
13609 need to be handled separately, as they are usually defined in
13610 runtime units that have been compiled without debugging info. */
13611
13612 ada_add_standard_exceptions (preg, &result);
13613
13614 /* Next, find all exceptions whose scope is local and accessible
13615 from the currently selected frame. */
13616
13617 if (has_stack_frames ())
13618 {
ab816a27 13619 prev_len = result.size ();
778865d3
JB
13620 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13621 &result);
ab816a27 13622 if (result.size () > prev_len)
778865d3
JB
13623 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13624 }
13625
13626 /* Add all exceptions whose scope is global. */
13627
ab816a27 13628 prev_len = result.size ();
778865d3 13629 ada_add_global_exceptions (preg, &result);
ab816a27 13630 if (result.size () > prev_len)
778865d3
JB
13631 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13632
778865d3
JB
13633 return result;
13634}
13635
13636/* Return a vector of ada_exc_info.
13637
13638 If REGEXP is NULL, all exceptions are included in the result.
13639 Otherwise, it should contain a valid regular expression,
13640 and only the exceptions whose names match that regular expression
13641 are included in the result.
13642
13643 The exceptions are sorted in the following order:
13644 - Standard exceptions (defined by the Ada language), in
13645 alphabetical order;
13646 - Exceptions only visible from the current frame, in
13647 alphabetical order;
13648 - Exceptions whose scope is global, in alphabetical order. */
13649
ab816a27 13650std::vector<ada_exc_info>
778865d3
JB
13651ada_exceptions_list (const char *regexp)
13652{
2d7cc5c7
PA
13653 if (regexp == NULL)
13654 return ada_exceptions_list_1 (NULL);
778865d3 13655
2d7cc5c7
PA
13656 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13657 return ada_exceptions_list_1 (&reg);
778865d3
JB
13658}
13659
13660/* Implement the "info exceptions" command. */
13661
13662static void
1d12d88f 13663info_exceptions_command (const char *regexp, int from_tty)
778865d3 13664{
778865d3 13665 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13666
ab816a27 13667 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13668
13669 if (regexp != NULL)
13670 printf_filtered
13671 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13672 else
13673 printf_filtered (_("All defined Ada exceptions:\n"));
13674
ab816a27
TT
13675 for (const ada_exc_info &info : exceptions)
13676 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13677}
13678
4c4b4cd2
PH
13679 /* Operators */
13680/* Information about operators given special treatment in functions
13681 below. */
13682/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13683
13684#define ADA_OPERATORS \
13685 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13686 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13687 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13688 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13689 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13690 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13691 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13692 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13693 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13694 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13695 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13696 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13697 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13698 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13699 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13700 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13701 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13702 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13703 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13704
13705static void
554794dc
SDJ
13706ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13707 int *argsp)
4c4b4cd2
PH
13708{
13709 switch (exp->elts[pc - 1].opcode)
13710 {
76a01679 13711 default:
4c4b4cd2
PH
13712 operator_length_standard (exp, pc, oplenp, argsp);
13713 break;
13714
13715#define OP_DEFN(op, len, args, binop) \
13716 case op: *oplenp = len; *argsp = args; break;
13717 ADA_OPERATORS;
13718#undef OP_DEFN
52ce6436
PH
13719
13720 case OP_AGGREGATE:
13721 *oplenp = 3;
13722 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13723 break;
13724
13725 case OP_CHOICES:
13726 *oplenp = 3;
13727 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13728 break;
4c4b4cd2
PH
13729 }
13730}
13731
c0201579
JK
13732/* Implementation of the exp_descriptor method operator_check. */
13733
13734static int
13735ada_operator_check (struct expression *exp, int pos,
13736 int (*objfile_func) (struct objfile *objfile, void *data),
13737 void *data)
13738{
13739 const union exp_element *const elts = exp->elts;
13740 struct type *type = NULL;
13741
13742 switch (elts[pos].opcode)
13743 {
13744 case UNOP_IN_RANGE:
13745 case UNOP_QUAL:
13746 type = elts[pos + 1].type;
13747 break;
13748
13749 default:
13750 return operator_check_standard (exp, pos, objfile_func, data);
13751 }
13752
13753 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13754
13755 if (type && TYPE_OBJFILE (type)
13756 && (*objfile_func) (TYPE_OBJFILE (type), data))
13757 return 1;
13758
13759 return 0;
13760}
13761
a121b7c1 13762static const char *
4c4b4cd2
PH
13763ada_op_name (enum exp_opcode opcode)
13764{
13765 switch (opcode)
13766 {
76a01679 13767 default:
4c4b4cd2 13768 return op_name_standard (opcode);
52ce6436 13769
4c4b4cd2
PH
13770#define OP_DEFN(op, len, args, binop) case op: return #op;
13771 ADA_OPERATORS;
13772#undef OP_DEFN
52ce6436
PH
13773
13774 case OP_AGGREGATE:
13775 return "OP_AGGREGATE";
13776 case OP_CHOICES:
13777 return "OP_CHOICES";
13778 case OP_NAME:
13779 return "OP_NAME";
4c4b4cd2
PH
13780 }
13781}
13782
13783/* As for operator_length, but assumes PC is pointing at the first
13784 element of the operator, and gives meaningful results only for the
52ce6436 13785 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13786
13787static void
76a01679
JB
13788ada_forward_operator_length (struct expression *exp, int pc,
13789 int *oplenp, int *argsp)
4c4b4cd2 13790{
76a01679 13791 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13792 {
13793 default:
13794 *oplenp = *argsp = 0;
13795 break;
52ce6436 13796
4c4b4cd2
PH
13797#define OP_DEFN(op, len, args, binop) \
13798 case op: *oplenp = len; *argsp = args; break;
13799 ADA_OPERATORS;
13800#undef OP_DEFN
52ce6436
PH
13801
13802 case OP_AGGREGATE:
13803 *oplenp = 3;
13804 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13805 break;
13806
13807 case OP_CHOICES:
13808 *oplenp = 3;
13809 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13810 break;
13811
13812 case OP_STRING:
13813 case OP_NAME:
13814 {
13815 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13816
52ce6436
PH
13817 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13818 *argsp = 0;
13819 break;
13820 }
4c4b4cd2
PH
13821 }
13822}
13823
13824static int
13825ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13826{
13827 enum exp_opcode op = exp->elts[elt].opcode;
13828 int oplen, nargs;
13829 int pc = elt;
13830 int i;
76a01679 13831
4c4b4cd2
PH
13832 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13833
76a01679 13834 switch (op)
4c4b4cd2 13835 {
76a01679 13836 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13837 case OP_ATR_FIRST:
13838 case OP_ATR_LAST:
13839 case OP_ATR_LENGTH:
13840 case OP_ATR_IMAGE:
13841 case OP_ATR_MAX:
13842 case OP_ATR_MIN:
13843 case OP_ATR_MODULUS:
13844 case OP_ATR_POS:
13845 case OP_ATR_SIZE:
13846 case OP_ATR_TAG:
13847 case OP_ATR_VAL:
13848 break;
13849
13850 case UNOP_IN_RANGE:
13851 case UNOP_QUAL:
323e0a4a
AC
13852 /* XXX: gdb_sprint_host_address, type_sprint */
13853 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13854 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13855 fprintf_filtered (stream, " (");
13856 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13857 fprintf_filtered (stream, ")");
13858 break;
13859 case BINOP_IN_BOUNDS:
52ce6436
PH
13860 fprintf_filtered (stream, " (%d)",
13861 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13862 break;
13863 case TERNOP_IN_RANGE:
13864 break;
13865
52ce6436
PH
13866 case OP_AGGREGATE:
13867 case OP_OTHERS:
13868 case OP_DISCRETE_RANGE:
13869 case OP_POSITIONAL:
13870 case OP_CHOICES:
13871 break;
13872
13873 case OP_NAME:
13874 case OP_STRING:
13875 {
13876 char *name = &exp->elts[elt + 2].string;
13877 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13878
52ce6436
PH
13879 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13880 break;
13881 }
13882
4c4b4cd2
PH
13883 default:
13884 return dump_subexp_body_standard (exp, stream, elt);
13885 }
13886
13887 elt += oplen;
13888 for (i = 0; i < nargs; i += 1)
13889 elt = dump_subexp (exp, stream, elt);
13890
13891 return elt;
13892}
13893
13894/* The Ada extension of print_subexp (q.v.). */
13895
76a01679
JB
13896static void
13897ada_print_subexp (struct expression *exp, int *pos,
13898 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13899{
52ce6436 13900 int oplen, nargs, i;
4c4b4cd2
PH
13901 int pc = *pos;
13902 enum exp_opcode op = exp->elts[pc].opcode;
13903
13904 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13905
52ce6436 13906 *pos += oplen;
4c4b4cd2
PH
13907 switch (op)
13908 {
13909 default:
52ce6436 13910 *pos -= oplen;
4c4b4cd2
PH
13911 print_subexp_standard (exp, pos, stream, prec);
13912 return;
13913
13914 case OP_VAR_VALUE:
4c4b4cd2
PH
13915 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13916 return;
13917
13918 case BINOP_IN_BOUNDS:
323e0a4a 13919 /* XXX: sprint_subexp */
4c4b4cd2 13920 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13921 fputs_filtered (" in ", stream);
4c4b4cd2 13922 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13923 fputs_filtered ("'range", stream);
4c4b4cd2 13924 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13925 fprintf_filtered (stream, "(%ld)",
13926 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13927 return;
13928
13929 case TERNOP_IN_RANGE:
4c4b4cd2 13930 if (prec >= PREC_EQUAL)
76a01679 13931 fputs_filtered ("(", stream);
323e0a4a 13932 /* XXX: sprint_subexp */
4c4b4cd2 13933 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13934 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13935 print_subexp (exp, pos, stream, PREC_EQUAL);
13936 fputs_filtered (" .. ", stream);
13937 print_subexp (exp, pos, stream, PREC_EQUAL);
13938 if (prec >= PREC_EQUAL)
76a01679
JB
13939 fputs_filtered (")", stream);
13940 return;
4c4b4cd2
PH
13941
13942 case OP_ATR_FIRST:
13943 case OP_ATR_LAST:
13944 case OP_ATR_LENGTH:
13945 case OP_ATR_IMAGE:
13946 case OP_ATR_MAX:
13947 case OP_ATR_MIN:
13948 case OP_ATR_MODULUS:
13949 case OP_ATR_POS:
13950 case OP_ATR_SIZE:
13951 case OP_ATR_TAG:
13952 case OP_ATR_VAL:
4c4b4cd2 13953 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13954 {
13955 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13956 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13957 &type_print_raw_options);
76a01679
JB
13958 *pos += 3;
13959 }
4c4b4cd2 13960 else
76a01679 13961 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13962 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13963 if (nargs > 1)
76a01679
JB
13964 {
13965 int tem;
5b4ee69b 13966
76a01679
JB
13967 for (tem = 1; tem < nargs; tem += 1)
13968 {
13969 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13970 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13971 }
13972 fputs_filtered (")", stream);
13973 }
4c4b4cd2 13974 return;
14f9c5c9 13975
4c4b4cd2 13976 case UNOP_QUAL:
4c4b4cd2
PH
13977 type_print (exp->elts[pc + 1].type, "", stream, 0);
13978 fputs_filtered ("'(", stream);
13979 print_subexp (exp, pos, stream, PREC_PREFIX);
13980 fputs_filtered (")", stream);
13981 return;
14f9c5c9 13982
4c4b4cd2 13983 case UNOP_IN_RANGE:
323e0a4a 13984 /* XXX: sprint_subexp */
4c4b4cd2 13985 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13986 fputs_filtered (" in ", stream);
79d43c61
TT
13987 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13988 &type_print_raw_options);
4c4b4cd2 13989 return;
52ce6436
PH
13990
13991 case OP_DISCRETE_RANGE:
13992 print_subexp (exp, pos, stream, PREC_SUFFIX);
13993 fputs_filtered ("..", stream);
13994 print_subexp (exp, pos, stream, PREC_SUFFIX);
13995 return;
13996
13997 case OP_OTHERS:
13998 fputs_filtered ("others => ", stream);
13999 print_subexp (exp, pos, stream, PREC_SUFFIX);
14000 return;
14001
14002 case OP_CHOICES:
14003 for (i = 0; i < nargs-1; i += 1)
14004 {
14005 if (i > 0)
14006 fputs_filtered ("|", stream);
14007 print_subexp (exp, pos, stream, PREC_SUFFIX);
14008 }
14009 fputs_filtered (" => ", stream);
14010 print_subexp (exp, pos, stream, PREC_SUFFIX);
14011 return;
14012
14013 case OP_POSITIONAL:
14014 print_subexp (exp, pos, stream, PREC_SUFFIX);
14015 return;
14016
14017 case OP_AGGREGATE:
14018 fputs_filtered ("(", stream);
14019 for (i = 0; i < nargs; i += 1)
14020 {
14021 if (i > 0)
14022 fputs_filtered (", ", stream);
14023 print_subexp (exp, pos, stream, PREC_SUFFIX);
14024 }
14025 fputs_filtered (")", stream);
14026 return;
4c4b4cd2
PH
14027 }
14028}
14f9c5c9
AS
14029
14030/* Table mapping opcodes into strings for printing operators
14031 and precedences of the operators. */
14032
d2e4a39e
AS
14033static const struct op_print ada_op_print_tab[] = {
14034 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14035 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14036 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14037 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14038 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14039 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14040 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14041 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14042 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14043 {">=", BINOP_GEQ, PREC_ORDER, 0},
14044 {">", BINOP_GTR, PREC_ORDER, 0},
14045 {"<", BINOP_LESS, PREC_ORDER, 0},
14046 {">>", BINOP_RSH, PREC_SHIFT, 0},
14047 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14048 {"+", BINOP_ADD, PREC_ADD, 0},
14049 {"-", BINOP_SUB, PREC_ADD, 0},
14050 {"&", BINOP_CONCAT, PREC_ADD, 0},
14051 {"*", BINOP_MUL, PREC_MUL, 0},
14052 {"/", BINOP_DIV, PREC_MUL, 0},
14053 {"rem", BINOP_REM, PREC_MUL, 0},
14054 {"mod", BINOP_MOD, PREC_MUL, 0},
14055 {"**", BINOP_EXP, PREC_REPEAT, 0},
14056 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14057 {"-", UNOP_NEG, PREC_PREFIX, 0},
14058 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14059 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14060 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14061 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
14062 {".all", UNOP_IND, PREC_SUFFIX, 1},
14063 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14064 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 14065 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
14066};
14067\f
72d5681a
PH
14068enum ada_primitive_types {
14069 ada_primitive_type_int,
14070 ada_primitive_type_long,
14071 ada_primitive_type_short,
14072 ada_primitive_type_char,
14073 ada_primitive_type_float,
14074 ada_primitive_type_double,
14075 ada_primitive_type_void,
14076 ada_primitive_type_long_long,
14077 ada_primitive_type_long_double,
14078 ada_primitive_type_natural,
14079 ada_primitive_type_positive,
14080 ada_primitive_type_system_address,
08f49010 14081 ada_primitive_type_storage_offset,
72d5681a
PH
14082 nr_ada_primitive_types
14083};
6c038f32
PH
14084
14085static void
d4a9a881 14086ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
14087 struct language_arch_info *lai)
14088{
d4a9a881 14089 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 14090
72d5681a 14091 lai->primitive_type_vector
d4a9a881 14092 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 14093 struct type *);
e9bb382b
UW
14094
14095 lai->primitive_type_vector [ada_primitive_type_int]
14096 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14097 0, "integer");
14098 lai->primitive_type_vector [ada_primitive_type_long]
14099 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14100 0, "long_integer");
14101 lai->primitive_type_vector [ada_primitive_type_short]
14102 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14103 0, "short_integer");
14104 lai->string_char_type
14105 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 14106 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
14107 lai->primitive_type_vector [ada_primitive_type_float]
14108 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 14109 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
14110 lai->primitive_type_vector [ada_primitive_type_double]
14111 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14112 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14113 lai->primitive_type_vector [ada_primitive_type_long_long]
14114 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14115 0, "long_long_integer");
14116 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14117 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14118 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14119 lai->primitive_type_vector [ada_primitive_type_natural]
14120 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14121 0, "natural");
14122 lai->primitive_type_vector [ada_primitive_type_positive]
14123 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14124 0, "positive");
14125 lai->primitive_type_vector [ada_primitive_type_void]
14126 = builtin->builtin_void;
14127
14128 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14129 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14130 "void"));
72d5681a
PH
14131 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14132 = "system__address";
fbb06eb1 14133
08f49010
XR
14134 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14135 type. This is a signed integral type whose size is the same as
14136 the size of addresses. */
14137 {
14138 unsigned int addr_length = TYPE_LENGTH
14139 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14140
14141 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14142 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14143 "storage_offset");
14144 }
14145
47e729a8 14146 lai->bool_type_symbol = NULL;
fbb06eb1 14147 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14148}
6c038f32
PH
14149\f
14150 /* Language vector */
14151
14152/* Not really used, but needed in the ada_language_defn. */
14153
14154static void
6c7a06a3 14155emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14156{
6c7a06a3 14157 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14158}
14159
14160static int
410a0ff2 14161parse (struct parser_state *ps)
6c038f32
PH
14162{
14163 warnings_issued = 0;
410a0ff2 14164 return ada_parse (ps);
6c038f32
PH
14165}
14166
14167static const struct exp_descriptor ada_exp_descriptor = {
14168 ada_print_subexp,
14169 ada_operator_length,
c0201579 14170 ada_operator_check,
6c038f32
PH
14171 ada_op_name,
14172 ada_dump_subexp_body,
14173 ada_evaluate_subexp
14174};
14175
b5ec771e
PA
14176/* symbol_name_matcher_ftype adapter for wild_match. */
14177
14178static bool
14179do_wild_match (const char *symbol_search_name,
14180 const lookup_name_info &lookup_name,
a207cff2 14181 completion_match_result *comp_match_res)
b5ec771e
PA
14182{
14183 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14184}
14185
14186/* symbol_name_matcher_ftype adapter for full_match. */
14187
14188static bool
14189do_full_match (const char *symbol_search_name,
14190 const lookup_name_info &lookup_name,
a207cff2 14191 completion_match_result *comp_match_res)
b5ec771e
PA
14192{
14193 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14194}
14195
14196/* Build the Ada lookup name for LOOKUP_NAME. */
14197
14198ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14199{
14200 const std::string &user_name = lookup_name.name ();
14201
14202 if (user_name[0] == '<')
14203 {
14204 if (user_name.back () == '>')
14205 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14206 else
14207 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14208 m_encoded_p = true;
14209 m_verbatim_p = true;
14210 m_wild_match_p = false;
14211 m_standard_p = false;
14212 }
14213 else
14214 {
14215 m_verbatim_p = false;
14216
14217 m_encoded_p = user_name.find ("__") != std::string::npos;
14218
14219 if (!m_encoded_p)
14220 {
14221 const char *folded = ada_fold_name (user_name.c_str ());
14222 const char *encoded = ada_encode_1 (folded, false);
14223 if (encoded != NULL)
14224 m_encoded_name = encoded;
14225 else
14226 m_encoded_name = user_name;
14227 }
14228 else
14229 m_encoded_name = user_name;
14230
14231 /* Handle the 'package Standard' special case. See description
14232 of m_standard_p. */
14233 if (startswith (m_encoded_name.c_str (), "standard__"))
14234 {
14235 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14236 m_standard_p = true;
14237 }
14238 else
14239 m_standard_p = false;
74ccd7f5 14240
b5ec771e
PA
14241 /* If the name contains a ".", then the user is entering a fully
14242 qualified entity name, and the match must not be done in wild
14243 mode. Similarly, if the user wants to complete what looks
14244 like an encoded name, the match must not be done in wild
14245 mode. Also, in the standard__ special case always do
14246 non-wild matching. */
14247 m_wild_match_p
14248 = (lookup_name.match_type () != symbol_name_match_type::FULL
14249 && !m_encoded_p
14250 && !m_standard_p
14251 && user_name.find ('.') == std::string::npos);
14252 }
14253}
14254
14255/* symbol_name_matcher_ftype method for Ada. This only handles
14256 completion mode. */
14257
14258static bool
14259ada_symbol_name_matches (const char *symbol_search_name,
14260 const lookup_name_info &lookup_name,
a207cff2 14261 completion_match_result *comp_match_res)
74ccd7f5 14262{
b5ec771e
PA
14263 return lookup_name.ada ().matches (symbol_search_name,
14264 lookup_name.match_type (),
a207cff2 14265 comp_match_res);
b5ec771e
PA
14266}
14267
de63c46b
PA
14268/* A name matcher that matches the symbol name exactly, with
14269 strcmp. */
14270
14271static bool
14272literal_symbol_name_matcher (const char *symbol_search_name,
14273 const lookup_name_info &lookup_name,
14274 completion_match_result *comp_match_res)
14275{
14276 const std::string &name = lookup_name.name ();
14277
14278 int cmp = (lookup_name.completion_mode ()
14279 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14280 : strcmp (symbol_search_name, name.c_str ()));
14281 if (cmp == 0)
14282 {
14283 if (comp_match_res != NULL)
14284 comp_match_res->set_match (symbol_search_name);
14285 return true;
14286 }
14287 else
14288 return false;
14289}
14290
b5ec771e
PA
14291/* Implement the "la_get_symbol_name_matcher" language_defn method for
14292 Ada. */
14293
14294static symbol_name_matcher_ftype *
14295ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14296{
de63c46b
PA
14297 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14298 return literal_symbol_name_matcher;
14299
b5ec771e
PA
14300 if (lookup_name.completion_mode ())
14301 return ada_symbol_name_matches;
74ccd7f5 14302 else
b5ec771e
PA
14303 {
14304 if (lookup_name.ada ().wild_match_p ())
14305 return do_wild_match;
14306 else
14307 return do_full_match;
14308 }
74ccd7f5
JB
14309}
14310
a5ee536b
JB
14311/* Implement the "la_read_var_value" language_defn method for Ada. */
14312
14313static struct value *
63e43d3a
PMR
14314ada_read_var_value (struct symbol *var, const struct block *var_block,
14315 struct frame_info *frame)
a5ee536b 14316{
3977b71f 14317 const struct block *frame_block = NULL;
a5ee536b
JB
14318 struct symbol *renaming_sym = NULL;
14319
14320 /* The only case where default_read_var_value is not sufficient
14321 is when VAR is a renaming... */
14322 if (frame)
14323 frame_block = get_frame_block (frame, NULL);
14324 if (frame_block)
14325 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14326 if (renaming_sym != NULL)
14327 return ada_read_renaming_var_value (renaming_sym, frame_block);
14328
14329 /* This is a typical case where we expect the default_read_var_value
14330 function to work. */
63e43d3a 14331 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14332}
14333
56618e20
TT
14334static const char *ada_extensions[] =
14335{
14336 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14337};
14338
47e77640 14339extern const struct language_defn ada_language_defn = {
6c038f32 14340 "ada", /* Language name */
6abde28f 14341 "Ada",
6c038f32 14342 language_ada,
6c038f32 14343 range_check_off,
6c038f32
PH
14344 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14345 that's not quite what this means. */
6c038f32 14346 array_row_major,
9a044a89 14347 macro_expansion_no,
56618e20 14348 ada_extensions,
6c038f32
PH
14349 &ada_exp_descriptor,
14350 parse,
6c038f32
PH
14351 resolve,
14352 ada_printchar, /* Print a character constant */
14353 ada_printstr, /* Function to print string constant */
14354 emit_char, /* Function to print single char (not used) */
6c038f32 14355 ada_print_type, /* Print a type using appropriate syntax */
be942545 14356 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14357 ada_val_print, /* Print a value using appropriate syntax */
14358 ada_value_print, /* Print a top-level value */
a5ee536b 14359 ada_read_var_value, /* la_read_var_value */
6c038f32 14360 NULL, /* Language specific skip_trampoline */
2b2d9e11 14361 NULL, /* name_of_this */
59cc4834 14362 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14363 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14364 basic_lookup_transparent_type, /* lookup_transparent_type */
14365 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14366 ada_sniff_from_mangled_name,
0963b4bd
MS
14367 NULL, /* Language specific
14368 class_name_from_physname */
6c038f32
PH
14369 ada_op_print_tab, /* expression operators for printing */
14370 0, /* c-style arrays */
14371 1, /* String lower bound */
6c038f32 14372 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14373 ada_collect_symbol_completion_matches,
72d5681a 14374 ada_language_arch_info,
e79af960 14375 ada_print_array_index,
41f1b697 14376 default_pass_by_reference,
ae6a3a4c 14377 c_get_string,
e2b7af72 14378 ada_watch_location_expression,
b5ec771e 14379 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14380 ada_iterate_over_symbols,
5ffa0793 14381 default_search_name_hash,
a53b64ea 14382 &ada_varobj_ops,
bb2ec1b3
TT
14383 NULL,
14384 NULL,
6c038f32
PH
14385 LANG_MAGIC
14386};
14387
5bf03f13
JB
14388/* Command-list for the "set/show ada" prefix command. */
14389static struct cmd_list_element *set_ada_list;
14390static struct cmd_list_element *show_ada_list;
14391
14392/* Implement the "set ada" prefix command. */
14393
14394static void
981a3fb3 14395set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14396{
14397 printf_unfiltered (_(\
14398"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14399 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14400}
14401
14402/* Implement the "show ada" prefix command. */
14403
14404static void
981a3fb3 14405show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14406{
14407 cmd_show_list (show_ada_list, from_tty, "");
14408}
14409
2060206e
PA
14410static void
14411initialize_ada_catchpoint_ops (void)
14412{
14413 struct breakpoint_ops *ops;
14414
14415 initialize_breakpoint_ops ();
14416
14417 ops = &catch_exception_breakpoint_ops;
14418 *ops = bkpt_breakpoint_ops;
2060206e
PA
14419 ops->allocate_location = allocate_location_catch_exception;
14420 ops->re_set = re_set_catch_exception;
14421 ops->check_status = check_status_catch_exception;
14422 ops->print_it = print_it_catch_exception;
14423 ops->print_one = print_one_catch_exception;
14424 ops->print_mention = print_mention_catch_exception;
14425 ops->print_recreate = print_recreate_catch_exception;
14426
14427 ops = &catch_exception_unhandled_breakpoint_ops;
14428 *ops = bkpt_breakpoint_ops;
2060206e
PA
14429 ops->allocate_location = allocate_location_catch_exception_unhandled;
14430 ops->re_set = re_set_catch_exception_unhandled;
14431 ops->check_status = check_status_catch_exception_unhandled;
14432 ops->print_it = print_it_catch_exception_unhandled;
14433 ops->print_one = print_one_catch_exception_unhandled;
14434 ops->print_mention = print_mention_catch_exception_unhandled;
14435 ops->print_recreate = print_recreate_catch_exception_unhandled;
14436
14437 ops = &catch_assert_breakpoint_ops;
14438 *ops = bkpt_breakpoint_ops;
2060206e
PA
14439 ops->allocate_location = allocate_location_catch_assert;
14440 ops->re_set = re_set_catch_assert;
14441 ops->check_status = check_status_catch_assert;
14442 ops->print_it = print_it_catch_assert;
14443 ops->print_one = print_one_catch_assert;
14444 ops->print_mention = print_mention_catch_assert;
14445 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14446
14447 ops = &catch_handlers_breakpoint_ops;
14448 *ops = bkpt_breakpoint_ops;
14449 ops->allocate_location = allocate_location_catch_handlers;
14450 ops->re_set = re_set_catch_handlers;
14451 ops->check_status = check_status_catch_handlers;
14452 ops->print_it = print_it_catch_handlers;
14453 ops->print_one = print_one_catch_handlers;
14454 ops->print_mention = print_mention_catch_handlers;
14455 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14456}
14457
3d9434b5
JB
14458/* This module's 'new_objfile' observer. */
14459
14460static void
14461ada_new_objfile_observer (struct objfile *objfile)
14462{
14463 ada_clear_symbol_cache ();
14464}
14465
14466/* This module's 'free_objfile' observer. */
14467
14468static void
14469ada_free_objfile_observer (struct objfile *objfile)
14470{
14471 ada_clear_symbol_cache ();
14472}
14473
d2e4a39e 14474void
6c038f32 14475_initialize_ada_language (void)
14f9c5c9 14476{
2060206e
PA
14477 initialize_ada_catchpoint_ops ();
14478
5bf03f13 14479 add_prefix_cmd ("ada", no_class, set_ada_command,
470678d7 14480 _("Prefix command for changing Ada-specific settings"),
5bf03f13
JB
14481 &set_ada_list, "set ada ", 0, &setlist);
14482
14483 add_prefix_cmd ("ada", no_class, show_ada_command,
14484 _("Generic command for showing Ada-specific settings."),
14485 &show_ada_list, "show ada ", 0, &showlist);
14486
14487 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14488 &trust_pad_over_xvs, _("\
14489Enable or disable an optimization trusting PAD types over XVS types"), _("\
14490Show whether an optimization trusting PAD types over XVS types is activated"),
14491 _("\
14492This is related to the encoding used by the GNAT compiler. The debugger\n\
14493should normally trust the contents of PAD types, but certain older versions\n\
14494of GNAT have a bug that sometimes causes the information in the PAD type\n\
14495to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14496work around this bug. It is always safe to turn this option \"off\", but\n\
14497this incurs a slight performance penalty, so it is recommended to NOT change\n\
14498this option to \"off\" unless necessary."),
14499 NULL, NULL, &set_ada_list, &show_ada_list);
14500
d72413e6
PMR
14501 add_setshow_boolean_cmd ("print-signatures", class_vars,
14502 &print_signatures, _("\
14503Enable or disable the output of formal and return types for functions in the \
14504overloads selection menu"), _("\
14505Show whether the output of formal and return types for functions in the \
14506overloads selection menu is activated"),
14507 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14508
9ac4176b
PA
14509 add_catch_command ("exception", _("\
14510Catch Ada exceptions, when raised.\n\
60a90376
JB
14511Usage: catch exception [ ARG ]\n\
14512\n\
14513Without any argument, stop when any Ada exception is raised.\n\
14514If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14515being raised does not have a handler (and will therefore lead to the task's\n\
14516termination).\n\
14517Otherwise, the catchpoint only stops when the name of the exception being\n\
14518raised is the same as ARG."),
9ac4176b
PA
14519 catch_ada_exception_command,
14520 NULL,
14521 CATCH_PERMANENT,
14522 CATCH_TEMPORARY);
9f757bf7
XR
14523
14524 add_catch_command ("handlers", _("\
14525Catch Ada exceptions, when handled.\n\
14526With an argument, catch only exceptions with the given name."),
14527 catch_ada_handlers_command,
14528 NULL,
14529 CATCH_PERMANENT,
14530 CATCH_TEMPORARY);
9ac4176b
PA
14531 add_catch_command ("assert", _("\
14532Catch failed Ada assertions, when raised.\n\
14533With an argument, catch only exceptions with the given name."),
14534 catch_assert_command,
14535 NULL,
14536 CATCH_PERMANENT,
14537 CATCH_TEMPORARY);
14538
6c038f32 14539 varsize_limit = 65536;
3fcded8f
JB
14540 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14541 &varsize_limit, _("\
14542Set the maximum number of bytes allowed in a variable-size object."), _("\
14543Show the maximum number of bytes allowed in a variable-size object."), _("\
14544Attempts to access an object whose size is not a compile-time constant\n\
14545and exceeds this limit will cause an error."),
14546 NULL, NULL, &setlist, &showlist);
6c038f32 14547
778865d3
JB
14548 add_info ("exceptions", info_exceptions_command,
14549 _("\
14550List all Ada exception names.\n\
14551If a regular expression is passed as an argument, only those matching\n\
14552the regular expression are listed."));
14553
c6044dd1
JB
14554 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14555 _("Set Ada maintenance-related variables."),
14556 &maint_set_ada_cmdlist, "maintenance set ada ",
14557 0/*allow-unknown*/, &maintenance_set_cmdlist);
14558
14559 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14560 _("Show Ada maintenance-related variables"),
14561 &maint_show_ada_cmdlist, "maintenance show ada ",
14562 0/*allow-unknown*/, &maintenance_show_cmdlist);
14563
14564 add_setshow_boolean_cmd
14565 ("ignore-descriptive-types", class_maintenance,
14566 &ada_ignore_descriptive_types_p,
14567 _("Set whether descriptive types generated by GNAT should be ignored."),
14568 _("Show whether descriptive types generated by GNAT should be ignored."),
14569 _("\
14570When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14571DWARF attribute."),
14572 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14573
459a2e4c
TT
14574 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14575 NULL, xcalloc, xfree);
6b69afc4 14576
3d9434b5 14577 /* The ada-lang observers. */
76727919
TT
14578 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14579 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14580 gdb::observers::inferior_exit.attach (ada_inferior_exit);
ee01b665
JB
14581
14582 /* Setup various context-specific data. */
e802dbe0 14583 ada_inferior_data
8e260fc0 14584 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14585 ada_pspace_data_handle
14586 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14587}