]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Automatic date update in version.in
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
e2882c85 3 Copyright (C) 1992-2018 Free Software Foundation, Inc.
14f9c5c9 4
a9762ec7 5 This file is part of GDB.
14f9c5c9 6
a9762ec7
JB
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
14f9c5c9 11
a9762ec7
JB
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
14f9c5c9 16
a9762ec7
JB
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 19
96d887e8 20
4c4b4cd2 21#include "defs.h"
14f9c5c9 22#include <ctype.h>
14f9c5c9 23#include "demangle.h"
4c4b4cd2
PH
24#include "gdb_regex.h"
25#include "frame.h"
14f9c5c9
AS
26#include "symtab.h"
27#include "gdbtypes.h"
28#include "gdbcmd.h"
29#include "expression.h"
30#include "parser-defs.h"
31#include "language.h"
a53b64ea 32#include "varobj.h"
14f9c5c9
AS
33#include "c-lang.h"
34#include "inferior.h"
35#include "symfile.h"
36#include "objfiles.h"
37#include "breakpoint.h"
38#include "gdbcore.h"
4c4b4cd2
PH
39#include "hashtab.h"
40#include "gdb_obstack.h"
14f9c5c9 41#include "ada-lang.h"
4c4b4cd2 42#include "completer.h"
53ce3c39 43#include <sys/stat.h>
14f9c5c9 44#include "ui-out.h"
fe898f56 45#include "block.h"
04714b91 46#include "infcall.h"
de4f826b 47#include "dictionary.h"
f7f9143b
JB
48#include "annotate.h"
49#include "valprint.h"
9bbc9174 50#include "source.h"
76727919 51#include "observable.h"
2ba95b9b 52#include "vec.h"
692465f1 53#include "stack.h"
fa864999 54#include "gdb_vecs.h"
79d43c61 55#include "typeprint.h"
22cee43f 56#include "namespace.h"
14f9c5c9 57
ccefe4c4 58#include "psymtab.h"
40bc484c 59#include "value.h"
956a9fb9 60#include "mi/mi-common.h"
9ac4176b 61#include "arch-utils.h"
0fcd72ba 62#include "cli/cli-utils.h"
14bc53a8 63#include "common/function-view.h"
d5722aa2 64#include "common/byte-vector.h"
ab816a27 65#include <algorithm>
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40bc484c 107static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 108
4c4b4cd2 109static void ada_add_block_symbols (struct obstack *,
b5ec771e
PA
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
14f9c5c9 113
22cee43f 114static void ada_add_all_symbols (struct obstack *, const struct block *,
b5ec771e
PA
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
22cee43f 117
d12307c1 118static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 119
76a01679 120static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 121 const struct block *);
14f9c5c9 122
4c4b4cd2
PH
123static int num_defns_collected (struct obstack *);
124
d12307c1 125static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 126
e9d9f57e 127static struct value *resolve_subexp (expression_up *, int *, int,
76a01679 128 struct type *);
14f9c5c9 129
e9d9f57e 130static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 131 struct symbol *, const struct block *);
14f9c5c9 132
d2e4a39e 133static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 134
a121b7c1 135static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
136
137static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 138
d2e4a39e 139static int numeric_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int integer_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int scalar_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int discrete_type_p (struct type *);
14f9c5c9 146
aeb5907d
JB
147static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 153 const struct block *);
aeb5907d 154
a121b7c1 155static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 156 int, int);
4c4b4cd2 157
d2e4a39e 158static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 159
b4ba55a1
JB
160static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
d2e4a39e 163static int is_dynamic_field (struct type *, int);
14f9c5c9 164
10a2c479 165static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 166 const gdb_byte *,
4c4b4cd2
PH
167 CORE_ADDR, struct value *);
168
169static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 170
28c85d6c 171static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 172
d2e4a39e 173static struct type *to_static_fixed_type (struct type *);
f192137b 174static struct type *static_unwrap_type (struct type *type);
14f9c5c9 175
d2e4a39e 176static struct value *unwrap_value (struct value *);
14f9c5c9 177
ad82864c 178static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 179
ad82864c 180static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 181
ad82864c
JB
182static long decode_packed_array_bitsize (struct type *);
183
184static struct value *decode_constrained_packed_array (struct value *);
185
186static int ada_is_packed_array_type (struct type *);
187
188static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 189
d2e4a39e 190static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 191 struct value **);
14f9c5c9 192
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 struct objfile *objfile;
96d887e8 4917 struct minimal_symbol *msymbol;
4c4b4cd2 4918
7c7b6655
TT
4919 memset (&result, 0, sizeof (result));
4920
b5ec771e
PA
4921 symbol_name_match_type match_type = name_match_type_from_name (name);
4922 lookup_name_info lookup_name (name, match_type);
4923
4924 symbol_name_matcher_ftype *match_name
4925 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4926
96d887e8
PH
4927 ALL_MSYMBOLS (objfile, msymbol)
4928 {
b5ec771e 4929 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
96d887e8 4930 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4931 {
4932 result.minsym = msymbol;
4933 result.objfile = objfile;
4934 break;
4935 }
96d887e8 4936 }
4c4b4cd2 4937
7c7b6655 4938 return result;
96d887e8 4939}
4c4b4cd2 4940
96d887e8
PH
4941/* For all subprograms that statically enclose the subprogram of the
4942 selected frame, add symbols matching identifier NAME in DOMAIN
4943 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4944 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4945 with a wildcard prefix. */
4c4b4cd2 4946
96d887e8
PH
4947static void
4948add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4949 const lookup_name_info &lookup_name,
4950 domain_enum domain)
96d887e8 4951{
96d887e8 4952}
14f9c5c9 4953
96d887e8
PH
4954/* True if TYPE is definitely an artificial type supplied to a symbol
4955 for which no debugging information was given in the symbol file. */
14f9c5c9 4956
96d887e8
PH
4957static int
4958is_nondebugging_type (struct type *type)
4959{
0d5cff50 4960 const char *name = ada_type_name (type);
5b4ee69b 4961
96d887e8
PH
4962 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4963}
4c4b4cd2 4964
8f17729f
JB
4965/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4966 that are deemed "identical" for practical purposes.
4967
4968 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4969 types and that their number of enumerals is identical (in other
4970 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4971
4972static int
4973ada_identical_enum_types_p (struct type *type1, struct type *type2)
4974{
4975 int i;
4976
4977 /* The heuristic we use here is fairly conservative. We consider
4978 that 2 enumerate types are identical if they have the same
4979 number of enumerals and that all enumerals have the same
4980 underlying value and name. */
4981
4982 /* All enums in the type should have an identical underlying value. */
4983 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4984 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4985 return 0;
4986
4987 /* All enumerals should also have the same name (modulo any numerical
4988 suffix). */
4989 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4990 {
0d5cff50
DE
4991 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4992 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4993 int len_1 = strlen (name_1);
4994 int len_2 = strlen (name_2);
4995
4996 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4997 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4998 if (len_1 != len_2
4999 || strncmp (TYPE_FIELD_NAME (type1, i),
5000 TYPE_FIELD_NAME (type2, i),
5001 len_1) != 0)
5002 return 0;
5003 }
5004
5005 return 1;
5006}
5007
5008/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5009 that are deemed "identical" for practical purposes. Sometimes,
5010 enumerals are not strictly identical, but their types are so similar
5011 that they can be considered identical.
5012
5013 For instance, consider the following code:
5014
5015 type Color is (Black, Red, Green, Blue, White);
5016 type RGB_Color is new Color range Red .. Blue;
5017
5018 Type RGB_Color is a subrange of an implicit type which is a copy
5019 of type Color. If we call that implicit type RGB_ColorB ("B" is
5020 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5021 As a result, when an expression references any of the enumeral
5022 by name (Eg. "print green"), the expression is technically
5023 ambiguous and the user should be asked to disambiguate. But
5024 doing so would only hinder the user, since it wouldn't matter
5025 what choice he makes, the outcome would always be the same.
5026 So, for practical purposes, we consider them as the same. */
5027
5028static int
54d343a2 5029symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
5030{
5031 int i;
5032
5033 /* Before performing a thorough comparison check of each type,
5034 we perform a series of inexpensive checks. We expect that these
5035 checks will quickly fail in the vast majority of cases, and thus
5036 help prevent the unnecessary use of a more expensive comparison.
5037 Said comparison also expects us to make some of these checks
5038 (see ada_identical_enum_types_p). */
5039
5040 /* Quick check: All symbols should have an enum type. */
54d343a2 5041 for (i = 0; i < syms.size (); i++)
d12307c1 5042 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5043 return 0;
5044
5045 /* Quick check: They should all have the same value. */
54d343a2 5046 for (i = 1; i < syms.size (); i++)
d12307c1 5047 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5048 return 0;
5049
5050 /* Quick check: They should all have the same number of enumerals. */
54d343a2 5051 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5052 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5053 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5054 return 0;
5055
5056 /* All the sanity checks passed, so we might have a set of
5057 identical enumeration types. Perform a more complete
5058 comparison of the type of each symbol. */
54d343a2 5059 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5060 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5061 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5062 return 0;
5063
5064 return 1;
5065}
5066
54d343a2 5067/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
5068 duplicate other symbols in the list (The only case I know of where
5069 this happens is when object files containing stabs-in-ecoff are
5070 linked with files containing ordinary ecoff debugging symbols (or no
5071 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5072 Returns the number of items in the modified list. */
4c4b4cd2 5073
96d887e8 5074static int
54d343a2 5075remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5076{
5077 int i, j;
4c4b4cd2 5078
8f17729f
JB
5079 /* We should never be called with less than 2 symbols, as there
5080 cannot be any extra symbol in that case. But it's easy to
5081 handle, since we have nothing to do in that case. */
54d343a2
TT
5082 if (syms->size () < 2)
5083 return syms->size ();
8f17729f 5084
96d887e8 5085 i = 0;
54d343a2 5086 while (i < syms->size ())
96d887e8 5087 {
a35ddb44 5088 int remove_p = 0;
339c13b6
JB
5089
5090 /* If two symbols have the same name and one of them is a stub type,
5091 the get rid of the stub. */
5092
54d343a2
TT
5093 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5094 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5095 {
54d343a2 5096 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5097 {
5098 if (j != i
54d343a2
TT
5099 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5100 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5101 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5102 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5103 remove_p = 1;
339c13b6
JB
5104 }
5105 }
5106
5107 /* Two symbols with the same name, same class and same address
5108 should be identical. */
5109
54d343a2
TT
5110 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5111 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5112 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5113 {
54d343a2 5114 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5115 {
5116 if (i != j
54d343a2
TT
5117 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5118 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5119 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5120 && SYMBOL_CLASS ((*syms)[i].symbol)
5121 == SYMBOL_CLASS ((*syms)[j].symbol)
5122 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5123 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5124 remove_p = 1;
4c4b4cd2 5125 }
4c4b4cd2 5126 }
339c13b6 5127
a35ddb44 5128 if (remove_p)
54d343a2 5129 syms->erase (syms->begin () + i);
339c13b6 5130
96d887e8 5131 i += 1;
14f9c5c9 5132 }
8f17729f
JB
5133
5134 /* If all the remaining symbols are identical enumerals, then
5135 just keep the first one and discard the rest.
5136
5137 Unlike what we did previously, we do not discard any entry
5138 unless they are ALL identical. This is because the symbol
5139 comparison is not a strict comparison, but rather a practical
5140 comparison. If all symbols are considered identical, then
5141 we can just go ahead and use the first one and discard the rest.
5142 But if we cannot reduce the list to a single element, we have
5143 to ask the user to disambiguate anyways. And if we have to
5144 present a multiple-choice menu, it's less confusing if the list
5145 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5146 if (symbols_are_identical_enums (*syms))
5147 syms->resize (1);
8f17729f 5148
54d343a2 5149 return syms->size ();
14f9c5c9
AS
5150}
5151
96d887e8
PH
5152/* Given a type that corresponds to a renaming entity, use the type name
5153 to extract the scope (package name or function name, fully qualified,
5154 and following the GNAT encoding convention) where this renaming has been
49d83361 5155 defined. */
4c4b4cd2 5156
49d83361 5157static std::string
96d887e8 5158xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5159{
96d887e8 5160 /* The renaming types adhere to the following convention:
0963b4bd 5161 <scope>__<rename>___<XR extension>.
96d887e8
PH
5162 So, to extract the scope, we search for the "___XR" extension,
5163 and then backtrack until we find the first "__". */
76a01679 5164
a737d952 5165 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5166 const char *suffix = strstr (name, "___XR");
5167 const char *last;
14f9c5c9 5168
96d887e8
PH
5169 /* Now, backtrack a bit until we find the first "__". Start looking
5170 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5171
96d887e8
PH
5172 for (last = suffix - 3; last > name; last--)
5173 if (last[0] == '_' && last[1] == '_')
5174 break;
76a01679 5175
96d887e8 5176 /* Make a copy of scope and return it. */
49d83361 5177 return std::string (name, last);
4c4b4cd2
PH
5178}
5179
96d887e8 5180/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5181
96d887e8
PH
5182static int
5183is_package_name (const char *name)
4c4b4cd2 5184{
96d887e8
PH
5185 /* Here, We take advantage of the fact that no symbols are generated
5186 for packages, while symbols are generated for each function.
5187 So the condition for NAME represent a package becomes equivalent
5188 to NAME not existing in our list of symbols. There is only one
5189 small complication with library-level functions (see below). */
4c4b4cd2 5190
96d887e8
PH
5191 /* If it is a function that has not been defined at library level,
5192 then we should be able to look it up in the symbols. */
5193 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5194 return 0;
14f9c5c9 5195
96d887e8
PH
5196 /* Library-level function names start with "_ada_". See if function
5197 "_ada_" followed by NAME can be found. */
14f9c5c9 5198
96d887e8 5199 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5200 functions names cannot contain "__" in them. */
96d887e8
PH
5201 if (strstr (name, "__") != NULL)
5202 return 0;
4c4b4cd2 5203
528e1572 5204 std::string fun_name = string_printf ("_ada_%s", name);
14f9c5c9 5205
528e1572 5206 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
96d887e8 5207}
14f9c5c9 5208
96d887e8 5209/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5210 not visible from FUNCTION_NAME. */
14f9c5c9 5211
96d887e8 5212static int
0d5cff50 5213old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5214{
aeb5907d
JB
5215 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5216 return 0;
5217
49d83361 5218 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5219
96d887e8 5220 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5221 if (is_package_name (scope.c_str ()))
5222 return 0;
14f9c5c9 5223
96d887e8
PH
5224 /* Check that the rename is in the current function scope by checking
5225 that its name starts with SCOPE. */
76a01679 5226
96d887e8
PH
5227 /* If the function name starts with "_ada_", it means that it is
5228 a library-level function. Strip this prefix before doing the
5229 comparison, as the encoding for the renaming does not contain
5230 this prefix. */
61012eef 5231 if (startswith (function_name, "_ada_"))
96d887e8 5232 function_name += 5;
f26caa11 5233
49d83361 5234 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5235}
5236
aeb5907d
JB
5237/* Remove entries from SYMS that corresponds to a renaming entity that
5238 is not visible from the function associated with CURRENT_BLOCK or
5239 that is superfluous due to the presence of more specific renaming
5240 information. Places surviving symbols in the initial entries of
5241 SYMS and returns the number of surviving symbols.
96d887e8
PH
5242
5243 Rationale:
aeb5907d
JB
5244 First, in cases where an object renaming is implemented as a
5245 reference variable, GNAT may produce both the actual reference
5246 variable and the renaming encoding. In this case, we discard the
5247 latter.
5248
5249 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5250 entity. Unfortunately, STABS currently does not support the definition
5251 of types that are local to a given lexical block, so all renamings types
5252 are emitted at library level. As a consequence, if an application
5253 contains two renaming entities using the same name, and a user tries to
5254 print the value of one of these entities, the result of the ada symbol
5255 lookup will also contain the wrong renaming type.
f26caa11 5256
96d887e8
PH
5257 This function partially covers for this limitation by attempting to
5258 remove from the SYMS list renaming symbols that should be visible
5259 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5260 method with the current information available. The implementation
5261 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5262
5263 - When the user tries to print a rename in a function while there
5264 is another rename entity defined in a package: Normally, the
5265 rename in the function has precedence over the rename in the
5266 package, so the latter should be removed from the list. This is
5267 currently not the case.
5268
5269 - This function will incorrectly remove valid renames if
5270 the CURRENT_BLOCK corresponds to a function which symbol name
5271 has been changed by an "Export" pragma. As a consequence,
5272 the user will be unable to print such rename entities. */
4c4b4cd2 5273
14f9c5c9 5274static int
54d343a2
TT
5275remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5276 const struct block *current_block)
4c4b4cd2
PH
5277{
5278 struct symbol *current_function;
0d5cff50 5279 const char *current_function_name;
4c4b4cd2 5280 int i;
aeb5907d
JB
5281 int is_new_style_renaming;
5282
5283 /* If there is both a renaming foo___XR... encoded as a variable and
5284 a simple variable foo in the same block, discard the latter.
0963b4bd 5285 First, zero out such symbols, then compress. */
aeb5907d 5286 is_new_style_renaming = 0;
54d343a2 5287 for (i = 0; i < syms->size (); i += 1)
aeb5907d 5288 {
54d343a2
TT
5289 struct symbol *sym = (*syms)[i].symbol;
5290 const struct block *block = (*syms)[i].block;
aeb5907d
JB
5291 const char *name;
5292 const char *suffix;
5293
5294 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5295 continue;
5296 name = SYMBOL_LINKAGE_NAME (sym);
5297 suffix = strstr (name, "___XR");
5298
5299 if (suffix != NULL)
5300 {
5301 int name_len = suffix - name;
5302 int j;
5b4ee69b 5303
aeb5907d 5304 is_new_style_renaming = 1;
54d343a2
TT
5305 for (j = 0; j < syms->size (); j += 1)
5306 if (i != j && (*syms)[j].symbol != NULL
5307 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
aeb5907d 5308 name_len) == 0
54d343a2
TT
5309 && block == (*syms)[j].block)
5310 (*syms)[j].symbol = NULL;
aeb5907d
JB
5311 }
5312 }
5313 if (is_new_style_renaming)
5314 {
5315 int j, k;
5316
54d343a2
TT
5317 for (j = k = 0; j < syms->size (); j += 1)
5318 if ((*syms)[j].symbol != NULL)
aeb5907d 5319 {
54d343a2 5320 (*syms)[k] = (*syms)[j];
aeb5907d
JB
5321 k += 1;
5322 }
5323 return k;
5324 }
4c4b4cd2
PH
5325
5326 /* Extract the function name associated to CURRENT_BLOCK.
5327 Abort if unable to do so. */
76a01679 5328
4c4b4cd2 5329 if (current_block == NULL)
54d343a2 5330 return syms->size ();
76a01679 5331
7f0df278 5332 current_function = block_linkage_function (current_block);
4c4b4cd2 5333 if (current_function == NULL)
54d343a2 5334 return syms->size ();
4c4b4cd2
PH
5335
5336 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5337 if (current_function_name == NULL)
54d343a2 5338 return syms->size ();
4c4b4cd2
PH
5339
5340 /* Check each of the symbols, and remove it from the list if it is
5341 a type corresponding to a renaming that is out of the scope of
5342 the current block. */
5343
5344 i = 0;
54d343a2 5345 while (i < syms->size ())
4c4b4cd2 5346 {
54d343a2 5347 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
aeb5907d 5348 == ADA_OBJECT_RENAMING
54d343a2
TT
5349 && old_renaming_is_invisible ((*syms)[i].symbol,
5350 current_function_name))
5351 syms->erase (syms->begin () + i);
4c4b4cd2
PH
5352 else
5353 i += 1;
5354 }
5355
54d343a2 5356 return syms->size ();
4c4b4cd2
PH
5357}
5358
339c13b6
JB
5359/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5360 whose name and domain match NAME and DOMAIN respectively.
5361 If no match was found, then extend the search to "enclosing"
5362 routines (in other words, if we're inside a nested function,
5363 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5364 If WILD_MATCH_P is nonzero, perform the naming matching in
5365 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5366
5367 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5368
5369static void
b5ec771e
PA
5370ada_add_local_symbols (struct obstack *obstackp,
5371 const lookup_name_info &lookup_name,
5372 const struct block *block, domain_enum domain)
339c13b6
JB
5373{
5374 int block_depth = 0;
5375
5376 while (block != NULL)
5377 {
5378 block_depth += 1;
b5ec771e 5379 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5380
5381 /* If we found a non-function match, assume that's the one. */
5382 if (is_nonfunction (defns_collected (obstackp, 0),
5383 num_defns_collected (obstackp)))
5384 return;
5385
5386 block = BLOCK_SUPERBLOCK (block);
5387 }
5388
5389 /* If no luck so far, try to find NAME as a local symbol in some lexically
5390 enclosing subprogram. */
5391 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5392 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5393}
5394
ccefe4c4 5395/* An object of this type is used as the user_data argument when
40658b94 5396 calling the map_matching_symbols method. */
ccefe4c4 5397
40658b94 5398struct match_data
ccefe4c4 5399{
40658b94 5400 struct objfile *objfile;
ccefe4c4 5401 struct obstack *obstackp;
40658b94
PH
5402 struct symbol *arg_sym;
5403 int found_sym;
ccefe4c4
TT
5404};
5405
22cee43f 5406/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5407 to a list of symbols. DATA0 is a pointer to a struct match_data *
5408 containing the obstack that collects the symbol list, the file that SYM
5409 must come from, a flag indicating whether a non-argument symbol has
5410 been found in the current block, and the last argument symbol
5411 passed in SYM within the current block (if any). When SYM is null,
5412 marking the end of a block, the argument symbol is added if no
5413 other has been found. */
ccefe4c4 5414
40658b94
PH
5415static int
5416aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5417{
40658b94
PH
5418 struct match_data *data = (struct match_data *) data0;
5419
5420 if (sym == NULL)
5421 {
5422 if (!data->found_sym && data->arg_sym != NULL)
5423 add_defn_to_vec (data->obstackp,
5424 fixup_symbol_section (data->arg_sym, data->objfile),
5425 block);
5426 data->found_sym = 0;
5427 data->arg_sym = NULL;
5428 }
5429 else
5430 {
5431 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5432 return 0;
5433 else if (SYMBOL_IS_ARGUMENT (sym))
5434 data->arg_sym = sym;
5435 else
5436 {
5437 data->found_sym = 1;
5438 add_defn_to_vec (data->obstackp,
5439 fixup_symbol_section (sym, data->objfile),
5440 block);
5441 }
5442 }
5443 return 0;
5444}
5445
b5ec771e
PA
5446/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5447 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5448 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5449
5450static int
5451ada_add_block_renamings (struct obstack *obstackp,
5452 const struct block *block,
b5ec771e
PA
5453 const lookup_name_info &lookup_name,
5454 domain_enum domain)
22cee43f
PMR
5455{
5456 struct using_direct *renaming;
5457 int defns_mark = num_defns_collected (obstackp);
5458
b5ec771e
PA
5459 symbol_name_matcher_ftype *name_match
5460 = ada_get_symbol_name_matcher (lookup_name);
5461
22cee43f
PMR
5462 for (renaming = block_using (block);
5463 renaming != NULL;
5464 renaming = renaming->next)
5465 {
5466 const char *r_name;
22cee43f
PMR
5467
5468 /* Avoid infinite recursions: skip this renaming if we are actually
5469 already traversing it.
5470
5471 Currently, symbol lookup in Ada don't use the namespace machinery from
5472 C++/Fortran support: skip namespace imports that use them. */
5473 if (renaming->searched
5474 || (renaming->import_src != NULL
5475 && renaming->import_src[0] != '\0')
5476 || (renaming->import_dest != NULL
5477 && renaming->import_dest[0] != '\0'))
5478 continue;
5479 renaming->searched = 1;
5480
5481 /* TODO: here, we perform another name-based symbol lookup, which can
5482 pull its own multiple overloads. In theory, we should be able to do
5483 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5484 not a simple name. But in order to do this, we would need to enhance
5485 the DWARF reader to associate a symbol to this renaming, instead of a
5486 name. So, for now, we do something simpler: re-use the C++/Fortran
5487 namespace machinery. */
5488 r_name = (renaming->alias != NULL
5489 ? renaming->alias
5490 : renaming->declaration);
b5ec771e
PA
5491 if (name_match (r_name, lookup_name, NULL))
5492 {
5493 lookup_name_info decl_lookup_name (renaming->declaration,
5494 lookup_name.match_type ());
5495 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5496 1, NULL);
5497 }
22cee43f
PMR
5498 renaming->searched = 0;
5499 }
5500 return num_defns_collected (obstackp) != defns_mark;
5501}
5502
db230ce3
JB
5503/* Implements compare_names, but only applying the comparision using
5504 the given CASING. */
5b4ee69b 5505
40658b94 5506static int
db230ce3
JB
5507compare_names_with_case (const char *string1, const char *string2,
5508 enum case_sensitivity casing)
40658b94
PH
5509{
5510 while (*string1 != '\0' && *string2 != '\0')
5511 {
db230ce3
JB
5512 char c1, c2;
5513
40658b94
PH
5514 if (isspace (*string1) || isspace (*string2))
5515 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5516
5517 if (casing == case_sensitive_off)
5518 {
5519 c1 = tolower (*string1);
5520 c2 = tolower (*string2);
5521 }
5522 else
5523 {
5524 c1 = *string1;
5525 c2 = *string2;
5526 }
5527 if (c1 != c2)
40658b94 5528 break;
db230ce3 5529
40658b94
PH
5530 string1 += 1;
5531 string2 += 1;
5532 }
db230ce3 5533
40658b94
PH
5534 switch (*string1)
5535 {
5536 case '(':
5537 return strcmp_iw_ordered (string1, string2);
5538 case '_':
5539 if (*string2 == '\0')
5540 {
052874e8 5541 if (is_name_suffix (string1))
40658b94
PH
5542 return 0;
5543 else
1a1d5513 5544 return 1;
40658b94 5545 }
dbb8534f 5546 /* FALLTHROUGH */
40658b94
PH
5547 default:
5548 if (*string2 == '(')
5549 return strcmp_iw_ordered (string1, string2);
5550 else
db230ce3
JB
5551 {
5552 if (casing == case_sensitive_off)
5553 return tolower (*string1) - tolower (*string2);
5554 else
5555 return *string1 - *string2;
5556 }
40658b94 5557 }
ccefe4c4
TT
5558}
5559
db230ce3
JB
5560/* Compare STRING1 to STRING2, with results as for strcmp.
5561 Compatible with strcmp_iw_ordered in that...
5562
5563 strcmp_iw_ordered (STRING1, STRING2) <= 0
5564
5565 ... implies...
5566
5567 compare_names (STRING1, STRING2) <= 0
5568
5569 (they may differ as to what symbols compare equal). */
5570
5571static int
5572compare_names (const char *string1, const char *string2)
5573{
5574 int result;
5575
5576 /* Similar to what strcmp_iw_ordered does, we need to perform
5577 a case-insensitive comparison first, and only resort to
5578 a second, case-sensitive, comparison if the first one was
5579 not sufficient to differentiate the two strings. */
5580
5581 result = compare_names_with_case (string1, string2, case_sensitive_off);
5582 if (result == 0)
5583 result = compare_names_with_case (string1, string2, case_sensitive_on);
5584
5585 return result;
5586}
5587
b5ec771e
PA
5588/* Convenience function to get at the Ada encoded lookup name for
5589 LOOKUP_NAME, as a C string. */
5590
5591static const char *
5592ada_lookup_name (const lookup_name_info &lookup_name)
5593{
5594 return lookup_name.ada ().lookup_name ().c_str ();
5595}
5596
339c13b6 5597/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5598 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5599 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5600 symbols otherwise. */
339c13b6
JB
5601
5602static void
b5ec771e
PA
5603add_nonlocal_symbols (struct obstack *obstackp,
5604 const lookup_name_info &lookup_name,
5605 domain_enum domain, int global)
339c13b6
JB
5606{
5607 struct objfile *objfile;
22cee43f 5608 struct compunit_symtab *cu;
40658b94 5609 struct match_data data;
339c13b6 5610
6475f2fe 5611 memset (&data, 0, sizeof data);
ccefe4c4 5612 data.obstackp = obstackp;
339c13b6 5613
b5ec771e
PA
5614 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5615
ccefe4c4 5616 ALL_OBJFILES (objfile)
40658b94
PH
5617 {
5618 data.objfile = objfile;
5619
5620 if (is_wild_match)
b5ec771e
PA
5621 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5622 domain, global,
4186eb54 5623 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5624 symbol_name_match_type::WILD,
5625 NULL);
40658b94 5626 else
b5ec771e
PA
5627 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5628 domain, global,
4186eb54 5629 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5630 symbol_name_match_type::FULL,
5631 compare_names);
22cee43f
PMR
5632
5633 ALL_OBJFILE_COMPUNITS (objfile, cu)
5634 {
5635 const struct block *global_block
5636 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5637
b5ec771e
PA
5638 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5639 domain))
22cee43f
PMR
5640 data.found_sym = 1;
5641 }
40658b94
PH
5642 }
5643
5644 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5645 {
b5ec771e
PA
5646 const char *name = ada_lookup_name (lookup_name);
5647 std::string name1 = std::string ("<_ada_") + name + '>';
5648
40658b94
PH
5649 ALL_OBJFILES (objfile)
5650 {
40658b94 5651 data.objfile = objfile;
b5ec771e
PA
5652 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5653 domain, global,
0963b4bd
MS
5654 aux_add_nonlocal_symbols,
5655 &data,
b5ec771e
PA
5656 symbol_name_match_type::FULL,
5657 compare_names);
40658b94
PH
5658 }
5659 }
339c13b6
JB
5660}
5661
b5ec771e
PA
5662/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5663 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5664 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5665
22cee43f
PMR
5666 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5667 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5668 is the one match returned (no other matches in that or
d9680e73 5669 enclosing blocks is returned). If there are any matches in or
22cee43f 5670 surrounding BLOCK, then these alone are returned.
4eeaa230 5671
b5ec771e
PA
5672 Names prefixed with "standard__" are handled specially:
5673 "standard__" is first stripped off (by the lookup_name
5674 constructor), and only static and global symbols are searched.
14f9c5c9 5675
22cee43f
PMR
5676 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5677 to lookup global symbols. */
5678
5679static void
5680ada_add_all_symbols (struct obstack *obstackp,
5681 const struct block *block,
b5ec771e 5682 const lookup_name_info &lookup_name,
22cee43f
PMR
5683 domain_enum domain,
5684 int full_search,
5685 int *made_global_lookup_p)
14f9c5c9
AS
5686{
5687 struct symbol *sym;
14f9c5c9 5688
22cee43f
PMR
5689 if (made_global_lookup_p)
5690 *made_global_lookup_p = 0;
339c13b6
JB
5691
5692 /* Special case: If the user specifies a symbol name inside package
5693 Standard, do a non-wild matching of the symbol name without
5694 the "standard__" prefix. This was primarily introduced in order
5695 to allow the user to specifically access the standard exceptions
5696 using, for instance, Standard.Constraint_Error when Constraint_Error
5697 is ambiguous (due to the user defining its own Constraint_Error
5698 entity inside its program). */
b5ec771e
PA
5699 if (lookup_name.ada ().standard_p ())
5700 block = NULL;
4c4b4cd2 5701
339c13b6 5702 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5703
4eeaa230
DE
5704 if (block != NULL)
5705 {
5706 if (full_search)
b5ec771e 5707 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5708 else
5709 {
5710 /* In the !full_search case we're are being called by
5711 ada_iterate_over_symbols, and we don't want to search
5712 superblocks. */
b5ec771e 5713 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5714 }
22cee43f
PMR
5715 if (num_defns_collected (obstackp) > 0 || !full_search)
5716 return;
4eeaa230 5717 }
d2e4a39e 5718
339c13b6
JB
5719 /* No non-global symbols found. Check our cache to see if we have
5720 already performed this search before. If we have, then return
5721 the same result. */
5722
b5ec771e
PA
5723 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5724 domain, &sym, &block))
4c4b4cd2
PH
5725 {
5726 if (sym != NULL)
b5ec771e 5727 add_defn_to_vec (obstackp, sym, block);
22cee43f 5728 return;
4c4b4cd2 5729 }
14f9c5c9 5730
22cee43f
PMR
5731 if (made_global_lookup_p)
5732 *made_global_lookup_p = 1;
b1eedac9 5733
339c13b6
JB
5734 /* Search symbols from all global blocks. */
5735
b5ec771e 5736 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5737
4c4b4cd2 5738 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5739 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5740
22cee43f 5741 if (num_defns_collected (obstackp) == 0)
b5ec771e 5742 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5743}
5744
b5ec771e
PA
5745/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5746 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5747 matches.
54d343a2
TT
5748 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5749 found and the blocks and symbol tables (if any) in which they were
5750 found.
22cee43f
PMR
5751
5752 When full_search is non-zero, any non-function/non-enumeral
5753 symbol match within the nest of blocks whose innermost member is BLOCK,
5754 is the one match returned (no other matches in that or
5755 enclosing blocks is returned). If there are any matches in or
5756 surrounding BLOCK, then these alone are returned.
5757
5758 Names prefixed with "standard__" are handled specially: "standard__"
5759 is first stripped off, and only static and global symbols are searched. */
5760
5761static int
b5ec771e
PA
5762ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5763 const struct block *block,
22cee43f 5764 domain_enum domain,
54d343a2 5765 std::vector<struct block_symbol> *results,
22cee43f
PMR
5766 int full_search)
5767{
22cee43f
PMR
5768 int syms_from_global_search;
5769 int ndefns;
ec6a20c2 5770 auto_obstack obstack;
22cee43f 5771
ec6a20c2 5772 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5773 domain, full_search, &syms_from_global_search);
14f9c5c9 5774
ec6a20c2
JB
5775 ndefns = num_defns_collected (&obstack);
5776
54d343a2
TT
5777 struct block_symbol *base = defns_collected (&obstack, 1);
5778 for (int i = 0; i < ndefns; ++i)
5779 results->push_back (base[i]);
4c4b4cd2 5780
54d343a2 5781 ndefns = remove_extra_symbols (results);
4c4b4cd2 5782
b1eedac9 5783 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5784 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5785
b1eedac9 5786 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5787 cache_symbol (ada_lookup_name (lookup_name), domain,
5788 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5789
54d343a2 5790 ndefns = remove_irrelevant_renamings (results, block);
ec6a20c2 5791
14f9c5c9
AS
5792 return ndefns;
5793}
5794
b5ec771e 5795/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
54d343a2
TT
5796 in global scopes, returning the number of matches, and filling *RESULTS
5797 with (SYM,BLOCK) tuples.
ec6a20c2 5798
4eeaa230
DE
5799 See ada_lookup_symbol_list_worker for further details. */
5800
5801int
b5ec771e 5802ada_lookup_symbol_list (const char *name, const struct block *block,
54d343a2
TT
5803 domain_enum domain,
5804 std::vector<struct block_symbol> *results)
4eeaa230 5805{
b5ec771e
PA
5806 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5807 lookup_name_info lookup_name (name, name_match_type);
5808
5809 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5810}
5811
5812/* Implementation of the la_iterate_over_symbols method. */
5813
5814static void
14bc53a8 5815ada_iterate_over_symbols
b5ec771e
PA
5816 (const struct block *block, const lookup_name_info &name,
5817 domain_enum domain,
14bc53a8 5818 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5819{
5820 int ndefs, i;
54d343a2 5821 std::vector<struct block_symbol> results;
4eeaa230
DE
5822
5823 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2 5824
4eeaa230
DE
5825 for (i = 0; i < ndefs; ++i)
5826 {
7e41c8db 5827 if (!callback (&results[i]))
4eeaa230
DE
5828 break;
5829 }
5830}
5831
4e5c77fe
JB
5832/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5833 to 1, but choosing the first symbol found if there are multiple
5834 choices.
5835
5e2336be
JB
5836 The result is stored in *INFO, which must be non-NULL.
5837 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5838
5839void
5840ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5841 domain_enum domain,
d12307c1 5842 struct block_symbol *info)
14f9c5c9 5843{
b5ec771e
PA
5844 /* Since we already have an encoded name, wrap it in '<>' to force a
5845 verbatim match. Otherwise, if the name happens to not look like
5846 an encoded name (because it doesn't include a "__"),
5847 ada_lookup_name_info would re-encode/fold it again, and that
5848 would e.g., incorrectly lowercase object renaming names like
5849 "R28b" -> "r28b". */
5850 std::string verbatim = std::string ("<") + name + '>';
5851
5e2336be 5852 gdb_assert (info != NULL);
f98fc17b 5853 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5854}
aeb5907d
JB
5855
5856/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5857 scope and in global scopes, or NULL if none. NAME is folded and
5858 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5859 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5860 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5861
d12307c1 5862struct block_symbol
aeb5907d 5863ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5864 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5865{
5866 if (is_a_field_of_this != NULL)
5867 *is_a_field_of_this = 0;
5868
54d343a2 5869 std::vector<struct block_symbol> candidates;
f98fc17b 5870 int n_candidates;
f98fc17b
PA
5871
5872 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
f98fc17b
PA
5873
5874 if (n_candidates == 0)
54d343a2 5875 return {};
f98fc17b
PA
5876
5877 block_symbol info = candidates[0];
5878 info.symbol = fixup_symbol_section (info.symbol, NULL);
d12307c1 5879 return info;
4c4b4cd2 5880}
14f9c5c9 5881
d12307c1 5882static struct block_symbol
f606139a
DE
5883ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5884 const char *name,
76a01679 5885 const struct block *block,
21b556f4 5886 const domain_enum domain)
4c4b4cd2 5887{
d12307c1 5888 struct block_symbol sym;
04dccad0
JB
5889
5890 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5891 if (sym.symbol != NULL)
04dccad0
JB
5892 return sym;
5893
5894 /* If we haven't found a match at this point, try the primitive
5895 types. In other languages, this search is performed before
5896 searching for global symbols in order to short-circuit that
5897 global-symbol search if it happens that the name corresponds
5898 to a primitive type. But we cannot do the same in Ada, because
5899 it is perfectly legitimate for a program to declare a type which
5900 has the same name as a standard type. If looking up a type in
5901 that situation, we have traditionally ignored the primitive type
5902 in favor of user-defined types. This is why, unlike most other
5903 languages, we search the primitive types this late and only after
5904 having searched the global symbols without success. */
5905
5906 if (domain == VAR_DOMAIN)
5907 {
5908 struct gdbarch *gdbarch;
5909
5910 if (block == NULL)
5911 gdbarch = target_gdbarch ();
5912 else
5913 gdbarch = block_gdbarch (block);
d12307c1
PMR
5914 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5915 if (sym.symbol != NULL)
04dccad0
JB
5916 return sym;
5917 }
5918
d12307c1 5919 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5920}
5921
5922
4c4b4cd2
PH
5923/* True iff STR is a possible encoded suffix of a normal Ada name
5924 that is to be ignored for matching purposes. Suffixes of parallel
5925 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5926 are given by any of the regular expressions:
4c4b4cd2 5927
babe1480
JB
5928 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5929 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5930 TKB [subprogram suffix for task bodies]
babe1480 5931 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5932 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5933
5934 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5935 match is performed. This sequence is used to differentiate homonyms,
5936 is an optional part of a valid name suffix. */
4c4b4cd2 5937
14f9c5c9 5938static int
d2e4a39e 5939is_name_suffix (const char *str)
14f9c5c9
AS
5940{
5941 int k;
4c4b4cd2
PH
5942 const char *matching;
5943 const int len = strlen (str);
5944
babe1480
JB
5945 /* Skip optional leading __[0-9]+. */
5946
4c4b4cd2
PH
5947 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5948 {
babe1480
JB
5949 str += 3;
5950 while (isdigit (str[0]))
5951 str += 1;
4c4b4cd2 5952 }
babe1480
JB
5953
5954 /* [.$][0-9]+ */
4c4b4cd2 5955
babe1480 5956 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5957 {
babe1480 5958 matching = str + 1;
4c4b4cd2
PH
5959 while (isdigit (matching[0]))
5960 matching += 1;
5961 if (matching[0] == '\0')
5962 return 1;
5963 }
5964
5965 /* ___[0-9]+ */
babe1480 5966
4c4b4cd2
PH
5967 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5968 {
5969 matching = str + 3;
5970 while (isdigit (matching[0]))
5971 matching += 1;
5972 if (matching[0] == '\0')
5973 return 1;
5974 }
5975
9ac7f98e
JB
5976 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5977
5978 if (strcmp (str, "TKB") == 0)
5979 return 1;
5980
529cad9c
PH
5981#if 0
5982 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5983 with a N at the end. Unfortunately, the compiler uses the same
5984 convention for other internal types it creates. So treating
529cad9c 5985 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5986 some regressions. For instance, consider the case of an enumerated
5987 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5988 name ends with N.
5989 Having a single character like this as a suffix carrying some
0963b4bd 5990 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5991 to be something like "_N" instead. In the meantime, do not do
5992 the following check. */
5993 /* Protected Object Subprograms */
5994 if (len == 1 && str [0] == 'N')
5995 return 1;
5996#endif
5997
5998 /* _E[0-9]+[bs]$ */
5999 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6000 {
6001 matching = str + 3;
6002 while (isdigit (matching[0]))
6003 matching += 1;
6004 if ((matching[0] == 'b' || matching[0] == 's')
6005 && matching [1] == '\0')
6006 return 1;
6007 }
6008
4c4b4cd2
PH
6009 /* ??? We should not modify STR directly, as we are doing below. This
6010 is fine in this case, but may become problematic later if we find
6011 that this alternative did not work, and want to try matching
6012 another one from the begining of STR. Since we modified it, we
6013 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6014 if (str[0] == 'X')
6015 {
6016 str += 1;
d2e4a39e 6017 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6018 {
6019 if (str[0] != 'n' && str[0] != 'b')
6020 return 0;
6021 str += 1;
6022 }
14f9c5c9 6023 }
babe1480 6024
14f9c5c9
AS
6025 if (str[0] == '\000')
6026 return 1;
babe1480 6027
d2e4a39e 6028 if (str[0] == '_')
14f9c5c9
AS
6029 {
6030 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6031 return 0;
d2e4a39e 6032 if (str[2] == '_')
4c4b4cd2 6033 {
61ee279c
PH
6034 if (strcmp (str + 3, "JM") == 0)
6035 return 1;
6036 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6037 the LJM suffix in favor of the JM one. But we will
6038 still accept LJM as a valid suffix for a reasonable
6039 amount of time, just to allow ourselves to debug programs
6040 compiled using an older version of GNAT. */
4c4b4cd2
PH
6041 if (strcmp (str + 3, "LJM") == 0)
6042 return 1;
6043 if (str[3] != 'X')
6044 return 0;
1265e4aa
JB
6045 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6046 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6047 return 1;
6048 if (str[4] == 'R' && str[5] != 'T')
6049 return 1;
6050 return 0;
6051 }
6052 if (!isdigit (str[2]))
6053 return 0;
6054 for (k = 3; str[k] != '\0'; k += 1)
6055 if (!isdigit (str[k]) && str[k] != '_')
6056 return 0;
14f9c5c9
AS
6057 return 1;
6058 }
4c4b4cd2 6059 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6060 {
4c4b4cd2
PH
6061 for (k = 2; str[k] != '\0'; k += 1)
6062 if (!isdigit (str[k]) && str[k] != '_')
6063 return 0;
14f9c5c9
AS
6064 return 1;
6065 }
6066 return 0;
6067}
d2e4a39e 6068
aeb5907d
JB
6069/* Return non-zero if the string starting at NAME and ending before
6070 NAME_END contains no capital letters. */
529cad9c
PH
6071
6072static int
6073is_valid_name_for_wild_match (const char *name0)
6074{
6075 const char *decoded_name = ada_decode (name0);
6076 int i;
6077
5823c3ef
JB
6078 /* If the decoded name starts with an angle bracket, it means that
6079 NAME0 does not follow the GNAT encoding format. It should then
6080 not be allowed as a possible wild match. */
6081 if (decoded_name[0] == '<')
6082 return 0;
6083
529cad9c
PH
6084 for (i=0; decoded_name[i] != '\0'; i++)
6085 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6086 return 0;
6087
6088 return 1;
6089}
6090
73589123
PH
6091/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6092 that could start a simple name. Assumes that *NAMEP points into
6093 the string beginning at NAME0. */
4c4b4cd2 6094
14f9c5c9 6095static int
73589123 6096advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6097{
73589123 6098 const char *name = *namep;
5b4ee69b 6099
5823c3ef 6100 while (1)
14f9c5c9 6101 {
aa27d0b3 6102 int t0, t1;
73589123
PH
6103
6104 t0 = *name;
6105 if (t0 == '_')
6106 {
6107 t1 = name[1];
6108 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6109 {
6110 name += 1;
61012eef 6111 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6112 break;
6113 else
6114 name += 1;
6115 }
aa27d0b3
JB
6116 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6117 || name[2] == target0))
73589123
PH
6118 {
6119 name += 2;
6120 break;
6121 }
6122 else
6123 return 0;
6124 }
6125 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6126 name += 1;
6127 else
5823c3ef 6128 return 0;
73589123
PH
6129 }
6130
6131 *namep = name;
6132 return 1;
6133}
6134
b5ec771e
PA
6135/* Return true iff NAME encodes a name of the form prefix.PATN.
6136 Ignores any informational suffixes of NAME (i.e., for which
6137 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6138 simple name. */
73589123 6139
b5ec771e 6140static bool
73589123
PH
6141wild_match (const char *name, const char *patn)
6142{
22e048c9 6143 const char *p;
73589123
PH
6144 const char *name0 = name;
6145
6146 while (1)
6147 {
6148 const char *match = name;
6149
6150 if (*name == *patn)
6151 {
6152 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6153 if (*p != *name)
6154 break;
6155 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6156 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6157
6158 if (name[-1] == '_')
6159 name -= 1;
6160 }
6161 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6162 return false;
96d887e8 6163 }
96d887e8
PH
6164}
6165
b5ec771e
PA
6166/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6167 any trailing suffixes that encode debugging information or leading
6168 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6169 information that is ignored). */
40658b94 6170
b5ec771e 6171static bool
c4d840bd
PH
6172full_match (const char *sym_name, const char *search_name)
6173{
b5ec771e
PA
6174 size_t search_name_len = strlen (search_name);
6175
6176 if (strncmp (sym_name, search_name, search_name_len) == 0
6177 && is_name_suffix (sym_name + search_name_len))
6178 return true;
6179
6180 if (startswith (sym_name, "_ada_")
6181 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6182 && is_name_suffix (sym_name + search_name_len + 5))
6183 return true;
c4d840bd 6184
b5ec771e
PA
6185 return false;
6186}
c4d840bd 6187
b5ec771e
PA
6188/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6189 *defn_symbols, updating the list of symbols in OBSTACKP (if
6190 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6191
6192static void
6193ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6194 const struct block *block,
6195 const lookup_name_info &lookup_name,
6196 domain_enum domain, struct objfile *objfile)
96d887e8 6197{
8157b174 6198 struct block_iterator iter;
96d887e8
PH
6199 /* A matching argument symbol, if any. */
6200 struct symbol *arg_sym;
6201 /* Set true when we find a matching non-argument symbol. */
6202 int found_sym;
6203 struct symbol *sym;
6204
6205 arg_sym = NULL;
6206 found_sym = 0;
b5ec771e
PA
6207 for (sym = block_iter_match_first (block, lookup_name, &iter);
6208 sym != NULL;
6209 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6210 {
b5ec771e
PA
6211 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6212 SYMBOL_DOMAIN (sym), domain))
6213 {
6214 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6215 {
6216 if (SYMBOL_IS_ARGUMENT (sym))
6217 arg_sym = sym;
6218 else
6219 {
6220 found_sym = 1;
6221 add_defn_to_vec (obstackp,
6222 fixup_symbol_section (sym, objfile),
6223 block);
6224 }
6225 }
6226 }
96d887e8
PH
6227 }
6228
22cee43f
PMR
6229 /* Handle renamings. */
6230
b5ec771e 6231 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6232 found_sym = 1;
6233
96d887e8
PH
6234 if (!found_sym && arg_sym != NULL)
6235 {
76a01679
JB
6236 add_defn_to_vec (obstackp,
6237 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6238 block);
96d887e8
PH
6239 }
6240
b5ec771e 6241 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6242 {
6243 arg_sym = NULL;
6244 found_sym = 0;
b5ec771e
PA
6245 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6246 const char *name = ada_lookup_name.c_str ();
6247 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6248
6249 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6250 {
4186eb54
KS
6251 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6252 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6253 {
6254 int cmp;
6255
6256 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6257 if (cmp == 0)
6258 {
61012eef 6259 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6260 if (cmp == 0)
6261 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6262 name_len);
6263 }
6264
6265 if (cmp == 0
6266 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6267 {
2a2d4dc3
AS
6268 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6269 {
6270 if (SYMBOL_IS_ARGUMENT (sym))
6271 arg_sym = sym;
6272 else
6273 {
6274 found_sym = 1;
6275 add_defn_to_vec (obstackp,
6276 fixup_symbol_section (sym, objfile),
6277 block);
6278 }
6279 }
76a01679
JB
6280 }
6281 }
76a01679 6282 }
96d887e8
PH
6283
6284 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6285 They aren't parameters, right? */
6286 if (!found_sym && arg_sym != NULL)
6287 {
6288 add_defn_to_vec (obstackp,
76a01679 6289 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6290 block);
96d887e8
PH
6291 }
6292 }
6293}
6294\f
41d27058
JB
6295
6296 /* Symbol Completion */
6297
b5ec771e 6298/* See symtab.h. */
41d27058 6299
b5ec771e
PA
6300bool
6301ada_lookup_name_info::matches
6302 (const char *sym_name,
6303 symbol_name_match_type match_type,
a207cff2 6304 completion_match_result *comp_match_res) const
41d27058 6305{
b5ec771e
PA
6306 bool match = false;
6307 const char *text = m_encoded_name.c_str ();
6308 size_t text_len = m_encoded_name.size ();
41d27058
JB
6309
6310 /* First, test against the fully qualified name of the symbol. */
6311
6312 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6313 match = true;
41d27058 6314
b5ec771e 6315 if (match && !m_encoded_p)
41d27058
JB
6316 {
6317 /* One needed check before declaring a positive match is to verify
6318 that iff we are doing a verbatim match, the decoded version
6319 of the symbol name starts with '<'. Otherwise, this symbol name
6320 is not a suitable completion. */
6321 const char *sym_name_copy = sym_name;
b5ec771e 6322 bool has_angle_bracket;
41d27058
JB
6323
6324 sym_name = ada_decode (sym_name);
6325 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6326 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6327 sym_name = sym_name_copy;
6328 }
6329
b5ec771e 6330 if (match && !m_verbatim_p)
41d27058
JB
6331 {
6332 /* When doing non-verbatim match, another check that needs to
6333 be done is to verify that the potentially matching symbol name
6334 does not include capital letters, because the ada-mode would
6335 not be able to understand these symbol names without the
6336 angle bracket notation. */
6337 const char *tmp;
6338
6339 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6340 if (*tmp != '\0')
b5ec771e 6341 match = false;
41d27058
JB
6342 }
6343
6344 /* Second: Try wild matching... */
6345
b5ec771e 6346 if (!match && m_wild_match_p)
41d27058
JB
6347 {
6348 /* Since we are doing wild matching, this means that TEXT
6349 may represent an unqualified symbol name. We therefore must
6350 also compare TEXT against the unqualified name of the symbol. */
6351 sym_name = ada_unqualified_name (ada_decode (sym_name));
6352
6353 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6354 match = true;
41d27058
JB
6355 }
6356
b5ec771e 6357 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6358
6359 if (!match)
b5ec771e 6360 return false;
41d27058 6361
a207cff2 6362 if (comp_match_res != NULL)
b5ec771e 6363 {
a207cff2 6364 std::string &match_str = comp_match_res->match.storage ();
41d27058 6365
b5ec771e 6366 if (!m_encoded_p)
a207cff2 6367 match_str = ada_decode (sym_name);
b5ec771e
PA
6368 else
6369 {
6370 if (m_verbatim_p)
6371 match_str = add_angle_brackets (sym_name);
6372 else
6373 match_str = sym_name;
41d27058 6374
b5ec771e 6375 }
a207cff2
PA
6376
6377 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6378 }
6379
b5ec771e 6380 return true;
41d27058
JB
6381}
6382
b5ec771e 6383/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6384 WORD is the entire command on which completion is made. */
41d27058 6385
eb3ff9a5
PA
6386static void
6387ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6388 complete_symbol_mode mode,
b5ec771e
PA
6389 symbol_name_match_type name_match_type,
6390 const char *text, const char *word,
eb3ff9a5 6391 enum type_code code)
41d27058 6392{
41d27058 6393 struct symbol *sym;
43f3e411 6394 struct compunit_symtab *s;
41d27058
JB
6395 struct minimal_symbol *msymbol;
6396 struct objfile *objfile;
3977b71f 6397 const struct block *b, *surrounding_static_block = 0;
8157b174 6398 struct block_iterator iter;
41d27058 6399
2f68a895
TT
6400 gdb_assert (code == TYPE_CODE_UNDEF);
6401
1b026119 6402 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6403
6404 /* First, look at the partial symtab symbols. */
14bc53a8 6405 expand_symtabs_matching (NULL,
b5ec771e
PA
6406 lookup_name,
6407 NULL,
14bc53a8
PA
6408 NULL,
6409 ALL_DOMAIN);
41d27058
JB
6410
6411 /* At this point scan through the misc symbol vectors and add each
6412 symbol you find to the list. Eventually we want to ignore
6413 anything that isn't a text symbol (everything else will be
6414 handled by the psymtab code above). */
6415
6416 ALL_MSYMBOLS (objfile, msymbol)
6417 {
6418 QUIT;
b5ec771e 6419
f9d67a22
PA
6420 if (completion_skip_symbol (mode, msymbol))
6421 continue;
6422
d4c2a405
PA
6423 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6424
6425 /* Ada minimal symbols won't have their language set to Ada. If
6426 we let completion_list_add_name compare using the
6427 default/C-like matcher, then when completing e.g., symbols in a
6428 package named "pck", we'd match internal Ada symbols like
6429 "pckS", which are invalid in an Ada expression, unless you wrap
6430 them in '<' '>' to request a verbatim match.
6431
6432 Unfortunately, some Ada encoded names successfully demangle as
6433 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6434 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6435 with the wrong language set. Paper over that issue here. */
6436 if (symbol_language == language_auto
6437 || symbol_language == language_cplus)
6438 symbol_language = language_ada;
6439
b5ec771e 6440 completion_list_add_name (tracker,
d4c2a405 6441 symbol_language,
b5ec771e 6442 MSYMBOL_LINKAGE_NAME (msymbol),
1b026119 6443 lookup_name, text, word);
41d27058
JB
6444 }
6445
6446 /* Search upwards from currently selected frame (so that we can
6447 complete on local vars. */
6448
6449 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6450 {
6451 if (!BLOCK_SUPERBLOCK (b))
6452 surrounding_static_block = b; /* For elmin of dups */
6453
6454 ALL_BLOCK_SYMBOLS (b, iter, sym)
6455 {
f9d67a22
PA
6456 if (completion_skip_symbol (mode, sym))
6457 continue;
6458
b5ec771e
PA
6459 completion_list_add_name (tracker,
6460 SYMBOL_LANGUAGE (sym),
6461 SYMBOL_LINKAGE_NAME (sym),
1b026119 6462 lookup_name, text, word);
41d27058
JB
6463 }
6464 }
6465
6466 /* Go through the symtabs and check the externs and statics for
43f3e411 6467 symbols which match. */
41d27058 6468
43f3e411 6469 ALL_COMPUNITS (objfile, s)
41d27058
JB
6470 {
6471 QUIT;
43f3e411 6472 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6473 ALL_BLOCK_SYMBOLS (b, iter, sym)
6474 {
f9d67a22
PA
6475 if (completion_skip_symbol (mode, sym))
6476 continue;
6477
b5ec771e
PA
6478 completion_list_add_name (tracker,
6479 SYMBOL_LANGUAGE (sym),
6480 SYMBOL_LINKAGE_NAME (sym),
1b026119 6481 lookup_name, text, word);
41d27058
JB
6482 }
6483 }
6484
43f3e411 6485 ALL_COMPUNITS (objfile, s)
41d27058
JB
6486 {
6487 QUIT;
43f3e411 6488 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6489 /* Don't do this block twice. */
6490 if (b == surrounding_static_block)
6491 continue;
6492 ALL_BLOCK_SYMBOLS (b, iter, sym)
6493 {
f9d67a22
PA
6494 if (completion_skip_symbol (mode, sym))
6495 continue;
6496
b5ec771e
PA
6497 completion_list_add_name (tracker,
6498 SYMBOL_LANGUAGE (sym),
6499 SYMBOL_LINKAGE_NAME (sym),
1b026119 6500 lookup_name, text, word);
41d27058
JB
6501 }
6502 }
41d27058
JB
6503}
6504
963a6417 6505 /* Field Access */
96d887e8 6506
73fb9985
JB
6507/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6508 for tagged types. */
6509
6510static int
6511ada_is_dispatch_table_ptr_type (struct type *type)
6512{
0d5cff50 6513 const char *name;
73fb9985
JB
6514
6515 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6516 return 0;
6517
6518 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6519 if (name == NULL)
6520 return 0;
6521
6522 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6523}
6524
ac4a2da4
JG
6525/* Return non-zero if TYPE is an interface tag. */
6526
6527static int
6528ada_is_interface_tag (struct type *type)
6529{
6530 const char *name = TYPE_NAME (type);
6531
6532 if (name == NULL)
6533 return 0;
6534
6535 return (strcmp (name, "ada__tags__interface_tag") == 0);
6536}
6537
963a6417
PH
6538/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6539 to be invisible to users. */
96d887e8 6540
963a6417
PH
6541int
6542ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6543{
963a6417
PH
6544 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6545 return 1;
ffde82bf 6546
73fb9985
JB
6547 /* Check the name of that field. */
6548 {
6549 const char *name = TYPE_FIELD_NAME (type, field_num);
6550
6551 /* Anonymous field names should not be printed.
6552 brobecker/2007-02-20: I don't think this can actually happen
6553 but we don't want to print the value of annonymous fields anyway. */
6554 if (name == NULL)
6555 return 1;
6556
ffde82bf
JB
6557 /* Normally, fields whose name start with an underscore ("_")
6558 are fields that have been internally generated by the compiler,
6559 and thus should not be printed. The "_parent" field is special,
6560 however: This is a field internally generated by the compiler
6561 for tagged types, and it contains the components inherited from
6562 the parent type. This field should not be printed as is, but
6563 should not be ignored either. */
61012eef 6564 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6565 return 1;
6566 }
6567
ac4a2da4
JG
6568 /* If this is the dispatch table of a tagged type or an interface tag,
6569 then ignore. */
73fb9985 6570 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6571 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6572 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6573 return 1;
6574
6575 /* Not a special field, so it should not be ignored. */
6576 return 0;
963a6417 6577}
96d887e8 6578
963a6417 6579/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6580 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6581
963a6417
PH
6582int
6583ada_is_tagged_type (struct type *type, int refok)
6584{
988f6b3d 6585 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6586}
96d887e8 6587
963a6417 6588/* True iff TYPE represents the type of X'Tag */
96d887e8 6589
963a6417
PH
6590int
6591ada_is_tag_type (struct type *type)
6592{
460efde1
JB
6593 type = ada_check_typedef (type);
6594
963a6417
PH
6595 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6596 return 0;
6597 else
96d887e8 6598 {
963a6417 6599 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6600
963a6417
PH
6601 return (name != NULL
6602 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6603 }
96d887e8
PH
6604}
6605
963a6417 6606/* The type of the tag on VAL. */
76a01679 6607
963a6417
PH
6608struct type *
6609ada_tag_type (struct value *val)
96d887e8 6610{
988f6b3d 6611 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6612}
96d887e8 6613
b50d69b5
JG
6614/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6615 retired at Ada 05). */
6616
6617static int
6618is_ada95_tag (struct value *tag)
6619{
6620 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6621}
6622
963a6417 6623/* The value of the tag on VAL. */
96d887e8 6624
963a6417
PH
6625struct value *
6626ada_value_tag (struct value *val)
6627{
03ee6b2e 6628 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6629}
6630
963a6417
PH
6631/* The value of the tag on the object of type TYPE whose contents are
6632 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6633 ADDRESS. */
96d887e8 6634
963a6417 6635static struct value *
10a2c479 6636value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6637 const gdb_byte *valaddr,
963a6417 6638 CORE_ADDR address)
96d887e8 6639{
b5385fc0 6640 int tag_byte_offset;
963a6417 6641 struct type *tag_type;
5b4ee69b 6642
963a6417 6643 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6644 NULL, NULL, NULL))
96d887e8 6645 {
fc1a4b47 6646 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6647 ? NULL
6648 : valaddr + tag_byte_offset);
963a6417 6649 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6650
963a6417 6651 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6652 }
963a6417
PH
6653 return NULL;
6654}
96d887e8 6655
963a6417
PH
6656static struct type *
6657type_from_tag (struct value *tag)
6658{
6659 const char *type_name = ada_tag_name (tag);
5b4ee69b 6660
963a6417
PH
6661 if (type_name != NULL)
6662 return ada_find_any_type (ada_encode (type_name));
6663 return NULL;
6664}
96d887e8 6665
b50d69b5
JG
6666/* Given a value OBJ of a tagged type, return a value of this
6667 type at the base address of the object. The base address, as
6668 defined in Ada.Tags, it is the address of the primary tag of
6669 the object, and therefore where the field values of its full
6670 view can be fetched. */
6671
6672struct value *
6673ada_tag_value_at_base_address (struct value *obj)
6674{
b50d69b5
JG
6675 struct value *val;
6676 LONGEST offset_to_top = 0;
6677 struct type *ptr_type, *obj_type;
6678 struct value *tag;
6679 CORE_ADDR base_address;
6680
6681 obj_type = value_type (obj);
6682
6683 /* It is the responsability of the caller to deref pointers. */
6684
6685 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6686 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6687 return obj;
6688
6689 tag = ada_value_tag (obj);
6690 if (!tag)
6691 return obj;
6692
6693 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6694
6695 if (is_ada95_tag (tag))
6696 return obj;
6697
08f49010
XR
6698 ptr_type = language_lookup_primitive_type
6699 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6700 ptr_type = lookup_pointer_type (ptr_type);
6701 val = value_cast (ptr_type, tag);
6702 if (!val)
6703 return obj;
6704
6705 /* It is perfectly possible that an exception be raised while
6706 trying to determine the base address, just like for the tag;
6707 see ada_tag_name for more details. We do not print the error
6708 message for the same reason. */
6709
492d29ea 6710 TRY
b50d69b5
JG
6711 {
6712 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6713 }
6714
492d29ea
PA
6715 CATCH (e, RETURN_MASK_ERROR)
6716 {
6717 return obj;
6718 }
6719 END_CATCH
b50d69b5
JG
6720
6721 /* If offset is null, nothing to do. */
6722
6723 if (offset_to_top == 0)
6724 return obj;
6725
6726 /* -1 is a special case in Ada.Tags; however, what should be done
6727 is not quite clear from the documentation. So do nothing for
6728 now. */
6729
6730 if (offset_to_top == -1)
6731 return obj;
6732
08f49010
XR
6733 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6734 from the base address. This was however incompatible with
6735 C++ dispatch table: C++ uses a *negative* value to *add*
6736 to the base address. Ada's convention has therefore been
6737 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6738 use the same convention. Here, we support both cases by
6739 checking the sign of OFFSET_TO_TOP. */
6740
6741 if (offset_to_top > 0)
6742 offset_to_top = -offset_to_top;
6743
6744 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6745 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6746
6747 /* Make sure that we have a proper tag at the new address.
6748 Otherwise, offset_to_top is bogus (which can happen when
6749 the object is not initialized yet). */
6750
6751 if (!tag)
6752 return obj;
6753
6754 obj_type = type_from_tag (tag);
6755
6756 if (!obj_type)
6757 return obj;
6758
6759 return value_from_contents_and_address (obj_type, NULL, base_address);
6760}
6761
1b611343
JB
6762/* Return the "ada__tags__type_specific_data" type. */
6763
6764static struct type *
6765ada_get_tsd_type (struct inferior *inf)
963a6417 6766{
1b611343 6767 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6768
1b611343
JB
6769 if (data->tsd_type == 0)
6770 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6771 return data->tsd_type;
6772}
529cad9c 6773
1b611343
JB
6774/* Return the TSD (type-specific data) associated to the given TAG.
6775 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6776
1b611343 6777 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6778
1b611343
JB
6779static struct value *
6780ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6781{
4c4b4cd2 6782 struct value *val;
1b611343 6783 struct type *type;
5b4ee69b 6784
1b611343
JB
6785 /* First option: The TSD is simply stored as a field of our TAG.
6786 Only older versions of GNAT would use this format, but we have
6787 to test it first, because there are no visible markers for
6788 the current approach except the absence of that field. */
529cad9c 6789
1b611343
JB
6790 val = ada_value_struct_elt (tag, "tsd", 1);
6791 if (val)
6792 return val;
e802dbe0 6793
1b611343
JB
6794 /* Try the second representation for the dispatch table (in which
6795 there is no explicit 'tsd' field in the referent of the tag pointer,
6796 and instead the tsd pointer is stored just before the dispatch
6797 table. */
e802dbe0 6798
1b611343
JB
6799 type = ada_get_tsd_type (current_inferior());
6800 if (type == NULL)
6801 return NULL;
6802 type = lookup_pointer_type (lookup_pointer_type (type));
6803 val = value_cast (type, tag);
6804 if (val == NULL)
6805 return NULL;
6806 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6807}
6808
1b611343
JB
6809/* Given the TSD of a tag (type-specific data), return a string
6810 containing the name of the associated type.
6811
6812 The returned value is good until the next call. May return NULL
6813 if we are unable to determine the tag name. */
6814
6815static char *
6816ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6817{
529cad9c
PH
6818 static char name[1024];
6819 char *p;
1b611343 6820 struct value *val;
529cad9c 6821
1b611343 6822 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6823 if (val == NULL)
1b611343 6824 return NULL;
4c4b4cd2
PH
6825 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6826 for (p = name; *p != '\0'; p += 1)
6827 if (isalpha (*p))
6828 *p = tolower (*p);
1b611343 6829 return name;
4c4b4cd2
PH
6830}
6831
6832/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6833 a C string.
6834
6835 Return NULL if the TAG is not an Ada tag, or if we were unable to
6836 determine the name of that tag. The result is good until the next
6837 call. */
4c4b4cd2
PH
6838
6839const char *
6840ada_tag_name (struct value *tag)
6841{
1b611343 6842 char *name = NULL;
5b4ee69b 6843
df407dfe 6844 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6845 return NULL;
1b611343
JB
6846
6847 /* It is perfectly possible that an exception be raised while trying
6848 to determine the TAG's name, even under normal circumstances:
6849 The associated variable may be uninitialized or corrupted, for
6850 instance. We do not let any exception propagate past this point.
6851 instead we return NULL.
6852
6853 We also do not print the error message either (which often is very
6854 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6855 the caller print a more meaningful message if necessary. */
492d29ea 6856 TRY
1b611343
JB
6857 {
6858 struct value *tsd = ada_get_tsd_from_tag (tag);
6859
6860 if (tsd != NULL)
6861 name = ada_tag_name_from_tsd (tsd);
6862 }
492d29ea
PA
6863 CATCH (e, RETURN_MASK_ERROR)
6864 {
6865 }
6866 END_CATCH
1b611343
JB
6867
6868 return name;
4c4b4cd2
PH
6869}
6870
6871/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6872
d2e4a39e 6873struct type *
ebf56fd3 6874ada_parent_type (struct type *type)
14f9c5c9
AS
6875{
6876 int i;
6877
61ee279c 6878 type = ada_check_typedef (type);
14f9c5c9
AS
6879
6880 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6881 return NULL;
6882
6883 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6884 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6885 {
6886 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6887
6888 /* If the _parent field is a pointer, then dereference it. */
6889 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6890 parent_type = TYPE_TARGET_TYPE (parent_type);
6891 /* If there is a parallel XVS type, get the actual base type. */
6892 parent_type = ada_get_base_type (parent_type);
6893
6894 return ada_check_typedef (parent_type);
6895 }
14f9c5c9
AS
6896
6897 return NULL;
6898}
6899
4c4b4cd2
PH
6900/* True iff field number FIELD_NUM of structure type TYPE contains the
6901 parent-type (inherited) fields of a derived type. Assumes TYPE is
6902 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6903
6904int
ebf56fd3 6905ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6906{
61ee279c 6907 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6908
4c4b4cd2 6909 return (name != NULL
61012eef
GB
6910 && (startswith (name, "PARENT")
6911 || startswith (name, "_parent")));
14f9c5c9
AS
6912}
6913
4c4b4cd2 6914/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6915 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6916 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6917 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6918 structures. */
14f9c5c9
AS
6919
6920int
ebf56fd3 6921ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6922{
d2e4a39e 6923 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6924
dddc0e16
JB
6925 if (name != NULL && strcmp (name, "RETVAL") == 0)
6926 {
6927 /* This happens in functions with "out" or "in out" parameters
6928 which are passed by copy. For such functions, GNAT describes
6929 the function's return type as being a struct where the return
6930 value is in a field called RETVAL, and where the other "out"
6931 or "in out" parameters are fields of that struct. This is not
6932 a wrapper. */
6933 return 0;
6934 }
6935
d2e4a39e 6936 return (name != NULL
61012eef 6937 && (startswith (name, "PARENT")
4c4b4cd2 6938 || strcmp (name, "REP") == 0
61012eef 6939 || startswith (name, "_parent")
4c4b4cd2 6940 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6941}
6942
4c4b4cd2
PH
6943/* True iff field number FIELD_NUM of structure or union type TYPE
6944 is a variant wrapper. Assumes TYPE is a structure type with at least
6945 FIELD_NUM+1 fields. */
14f9c5c9
AS
6946
6947int
ebf56fd3 6948ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6949{
d2e4a39e 6950 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6951
14f9c5c9 6952 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6953 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6954 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6955 == TYPE_CODE_UNION)));
14f9c5c9
AS
6956}
6957
6958/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6959 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6960 returns the type of the controlling discriminant for the variant.
6961 May return NULL if the type could not be found. */
14f9c5c9 6962
d2e4a39e 6963struct type *
ebf56fd3 6964ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6965{
a121b7c1 6966 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6967
988f6b3d 6968 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
6969}
6970
4c4b4cd2 6971/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6972 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6973 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6974
6975int
ebf56fd3 6976ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6977{
d2e4a39e 6978 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6979
14f9c5c9
AS
6980 return (name != NULL && name[0] == 'O');
6981}
6982
6983/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6984 returns the name of the discriminant controlling the variant.
6985 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6986
a121b7c1 6987const char *
ebf56fd3 6988ada_variant_discrim_name (struct type *type0)
14f9c5c9 6989{
d2e4a39e 6990 static char *result = NULL;
14f9c5c9 6991 static size_t result_len = 0;
d2e4a39e
AS
6992 struct type *type;
6993 const char *name;
6994 const char *discrim_end;
6995 const char *discrim_start;
14f9c5c9
AS
6996
6997 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6998 type = TYPE_TARGET_TYPE (type0);
6999 else
7000 type = type0;
7001
7002 name = ada_type_name (type);
7003
7004 if (name == NULL || name[0] == '\000')
7005 return "";
7006
7007 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7008 discrim_end -= 1)
7009 {
61012eef 7010 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7011 break;
14f9c5c9
AS
7012 }
7013 if (discrim_end == name)
7014 return "";
7015
d2e4a39e 7016 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7017 discrim_start -= 1)
7018 {
d2e4a39e 7019 if (discrim_start == name + 1)
4c4b4cd2 7020 return "";
76a01679 7021 if ((discrim_start > name + 3
61012eef 7022 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7023 || discrim_start[-1] == '.')
7024 break;
14f9c5c9
AS
7025 }
7026
7027 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7028 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7029 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7030 return result;
7031}
7032
4c4b4cd2
PH
7033/* Scan STR for a subtype-encoded number, beginning at position K.
7034 Put the position of the character just past the number scanned in
7035 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7036 Return 1 if there was a valid number at the given position, and 0
7037 otherwise. A "subtype-encoded" number consists of the absolute value
7038 in decimal, followed by the letter 'm' to indicate a negative number.
7039 Assumes 0m does not occur. */
14f9c5c9
AS
7040
7041int
d2e4a39e 7042ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7043{
7044 ULONGEST RU;
7045
d2e4a39e 7046 if (!isdigit (str[k]))
14f9c5c9
AS
7047 return 0;
7048
4c4b4cd2 7049 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7050 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7051 LONGEST. */
14f9c5c9
AS
7052 RU = 0;
7053 while (isdigit (str[k]))
7054 {
d2e4a39e 7055 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7056 k += 1;
7057 }
7058
d2e4a39e 7059 if (str[k] == 'm')
14f9c5c9
AS
7060 {
7061 if (R != NULL)
4c4b4cd2 7062 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7063 k += 1;
7064 }
7065 else if (R != NULL)
7066 *R = (LONGEST) RU;
7067
4c4b4cd2 7068 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7069 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7070 number representable as a LONGEST (although either would probably work
7071 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7072 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7073
7074 if (new_k != NULL)
7075 *new_k = k;
7076 return 1;
7077}
7078
4c4b4cd2
PH
7079/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7080 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7081 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7082
d2e4a39e 7083int
ebf56fd3 7084ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7085{
d2e4a39e 7086 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7087 int p;
7088
7089 p = 0;
7090 while (1)
7091 {
d2e4a39e 7092 switch (name[p])
4c4b4cd2
PH
7093 {
7094 case '\0':
7095 return 0;
7096 case 'S':
7097 {
7098 LONGEST W;
5b4ee69b 7099
4c4b4cd2
PH
7100 if (!ada_scan_number (name, p + 1, &W, &p))
7101 return 0;
7102 if (val == W)
7103 return 1;
7104 break;
7105 }
7106 case 'R':
7107 {
7108 LONGEST L, U;
5b4ee69b 7109
4c4b4cd2
PH
7110 if (!ada_scan_number (name, p + 1, &L, &p)
7111 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7112 return 0;
7113 if (val >= L && val <= U)
7114 return 1;
7115 break;
7116 }
7117 case 'O':
7118 return 1;
7119 default:
7120 return 0;
7121 }
7122 }
7123}
7124
0963b4bd 7125/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7126
7127/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7128 ARG_TYPE, extract and return the value of one of its (non-static)
7129 fields. FIELDNO says which field. Differs from value_primitive_field
7130 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7131
4c4b4cd2 7132static struct value *
d2e4a39e 7133ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7134 struct type *arg_type)
14f9c5c9 7135{
14f9c5c9
AS
7136 struct type *type;
7137
61ee279c 7138 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7139 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7140
4c4b4cd2 7141 /* Handle packed fields. */
14f9c5c9
AS
7142
7143 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7144 {
7145 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7146 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7147
0fd88904 7148 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7149 offset + bit_pos / 8,
7150 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7151 }
7152 else
7153 return value_primitive_field (arg1, offset, fieldno, arg_type);
7154}
7155
52ce6436
PH
7156/* Find field with name NAME in object of type TYPE. If found,
7157 set the following for each argument that is non-null:
7158 - *FIELD_TYPE_P to the field's type;
7159 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7160 an object of that type;
7161 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7162 - *BIT_SIZE_P to its size in bits if the field is packed, and
7163 0 otherwise;
7164 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7165 fields up to but not including the desired field, or by the total
7166 number of fields if not found. A NULL value of NAME never
7167 matches; the function just counts visible fields in this case.
7168
828d5846
XR
7169 Notice that we need to handle when a tagged record hierarchy
7170 has some components with the same name, like in this scenario:
7171
7172 type Top_T is tagged record
7173 N : Integer := 1;
7174 U : Integer := 974;
7175 A : Integer := 48;
7176 end record;
7177
7178 type Middle_T is new Top.Top_T with record
7179 N : Character := 'a';
7180 C : Integer := 3;
7181 end record;
7182
7183 type Bottom_T is new Middle.Middle_T with record
7184 N : Float := 4.0;
7185 C : Character := '5';
7186 X : Integer := 6;
7187 A : Character := 'J';
7188 end record;
7189
7190 Let's say we now have a variable declared and initialized as follow:
7191
7192 TC : Top_A := new Bottom_T;
7193
7194 And then we use this variable to call this function
7195
7196 procedure Assign (Obj: in out Top_T; TV : Integer);
7197
7198 as follow:
7199
7200 Assign (Top_T (B), 12);
7201
7202 Now, we're in the debugger, and we're inside that procedure
7203 then and we want to print the value of obj.c:
7204
7205 Usually, the tagged record or one of the parent type owns the
7206 component to print and there's no issue but in this particular
7207 case, what does it mean to ask for Obj.C? Since the actual
7208 type for object is type Bottom_T, it could mean two things: type
7209 component C from the Middle_T view, but also component C from
7210 Bottom_T. So in that "undefined" case, when the component is
7211 not found in the non-resolved type (which includes all the
7212 components of the parent type), then resolve it and see if we
7213 get better luck once expanded.
7214
7215 In the case of homonyms in the derived tagged type, we don't
7216 guaranty anything, and pick the one that's easiest for us
7217 to program.
7218
0963b4bd 7219 Returns 1 if found, 0 otherwise. */
52ce6436 7220
4c4b4cd2 7221static int
0d5cff50 7222find_struct_field (const char *name, struct type *type, int offset,
76a01679 7223 struct type **field_type_p,
52ce6436
PH
7224 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7225 int *index_p)
4c4b4cd2
PH
7226{
7227 int i;
828d5846 7228 int parent_offset = -1;
4c4b4cd2 7229
61ee279c 7230 type = ada_check_typedef (type);
76a01679 7231
52ce6436
PH
7232 if (field_type_p != NULL)
7233 *field_type_p = NULL;
7234 if (byte_offset_p != NULL)
d5d6fca5 7235 *byte_offset_p = 0;
52ce6436
PH
7236 if (bit_offset_p != NULL)
7237 *bit_offset_p = 0;
7238 if (bit_size_p != NULL)
7239 *bit_size_p = 0;
7240
7241 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7242 {
7243 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7244 int fld_offset = offset + bit_pos / 8;
0d5cff50 7245 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7246
4c4b4cd2
PH
7247 if (t_field_name == NULL)
7248 continue;
7249
828d5846
XR
7250 else if (ada_is_parent_field (type, i))
7251 {
7252 /* This is a field pointing us to the parent type of a tagged
7253 type. As hinted in this function's documentation, we give
7254 preference to fields in the current record first, so what
7255 we do here is just record the index of this field before
7256 we skip it. If it turns out we couldn't find our field
7257 in the current record, then we'll get back to it and search
7258 inside it whether the field might exist in the parent. */
7259
7260 parent_offset = i;
7261 continue;
7262 }
7263
52ce6436 7264 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7265 {
7266 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7267
52ce6436
PH
7268 if (field_type_p != NULL)
7269 *field_type_p = TYPE_FIELD_TYPE (type, i);
7270 if (byte_offset_p != NULL)
7271 *byte_offset_p = fld_offset;
7272 if (bit_offset_p != NULL)
7273 *bit_offset_p = bit_pos % 8;
7274 if (bit_size_p != NULL)
7275 *bit_size_p = bit_size;
76a01679
JB
7276 return 1;
7277 }
4c4b4cd2
PH
7278 else if (ada_is_wrapper_field (type, i))
7279 {
52ce6436
PH
7280 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7281 field_type_p, byte_offset_p, bit_offset_p,
7282 bit_size_p, index_p))
76a01679
JB
7283 return 1;
7284 }
4c4b4cd2
PH
7285 else if (ada_is_variant_part (type, i))
7286 {
52ce6436
PH
7287 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7288 fixed type?? */
4c4b4cd2 7289 int j;
52ce6436
PH
7290 struct type *field_type
7291 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7292
52ce6436 7293 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7294 {
76a01679
JB
7295 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7296 fld_offset
7297 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7298 field_type_p, byte_offset_p,
52ce6436 7299 bit_offset_p, bit_size_p, index_p))
76a01679 7300 return 1;
4c4b4cd2
PH
7301 }
7302 }
52ce6436
PH
7303 else if (index_p != NULL)
7304 *index_p += 1;
4c4b4cd2 7305 }
828d5846
XR
7306
7307 /* Field not found so far. If this is a tagged type which
7308 has a parent, try finding that field in the parent now. */
7309
7310 if (parent_offset != -1)
7311 {
7312 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7313 int fld_offset = offset + bit_pos / 8;
7314
7315 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7316 fld_offset, field_type_p, byte_offset_p,
7317 bit_offset_p, bit_size_p, index_p))
7318 return 1;
7319 }
7320
4c4b4cd2
PH
7321 return 0;
7322}
7323
0963b4bd 7324/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7325
52ce6436
PH
7326static int
7327num_visible_fields (struct type *type)
7328{
7329 int n;
5b4ee69b 7330
52ce6436
PH
7331 n = 0;
7332 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7333 return n;
7334}
14f9c5c9 7335
4c4b4cd2 7336/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7337 and search in it assuming it has (class) type TYPE.
7338 If found, return value, else return NULL.
7339
828d5846
XR
7340 Searches recursively through wrapper fields (e.g., '_parent').
7341
7342 In the case of homonyms in the tagged types, please refer to the
7343 long explanation in find_struct_field's function documentation. */
14f9c5c9 7344
4c4b4cd2 7345static struct value *
108d56a4 7346ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7347 struct type *type)
14f9c5c9
AS
7348{
7349 int i;
828d5846 7350 int parent_offset = -1;
14f9c5c9 7351
5b4ee69b 7352 type = ada_check_typedef (type);
52ce6436 7353 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7354 {
0d5cff50 7355 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7356
7357 if (t_field_name == NULL)
4c4b4cd2 7358 continue;
14f9c5c9 7359
828d5846
XR
7360 else if (ada_is_parent_field (type, i))
7361 {
7362 /* This is a field pointing us to the parent type of a tagged
7363 type. As hinted in this function's documentation, we give
7364 preference to fields in the current record first, so what
7365 we do here is just record the index of this field before
7366 we skip it. If it turns out we couldn't find our field
7367 in the current record, then we'll get back to it and search
7368 inside it whether the field might exist in the parent. */
7369
7370 parent_offset = i;
7371 continue;
7372 }
7373
14f9c5c9 7374 else if (field_name_match (t_field_name, name))
4c4b4cd2 7375 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7376
7377 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7378 {
0963b4bd 7379 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7380 ada_search_struct_field (name, arg,
7381 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7382 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7383
4c4b4cd2
PH
7384 if (v != NULL)
7385 return v;
7386 }
14f9c5c9
AS
7387
7388 else if (ada_is_variant_part (type, i))
4c4b4cd2 7389 {
0963b4bd 7390 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7391 int j;
5b4ee69b
MS
7392 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7393 i));
4c4b4cd2
PH
7394 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7395
52ce6436 7396 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7397 {
0963b4bd
MS
7398 struct value *v = ada_search_struct_field /* Force line
7399 break. */
06d5cf63
JB
7400 (name, arg,
7401 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7402 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7403
4c4b4cd2
PH
7404 if (v != NULL)
7405 return v;
7406 }
7407 }
14f9c5c9 7408 }
828d5846
XR
7409
7410 /* Field not found so far. If this is a tagged type which
7411 has a parent, try finding that field in the parent now. */
7412
7413 if (parent_offset != -1)
7414 {
7415 struct value *v = ada_search_struct_field (
7416 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7417 TYPE_FIELD_TYPE (type, parent_offset));
7418
7419 if (v != NULL)
7420 return v;
7421 }
7422
14f9c5c9
AS
7423 return NULL;
7424}
d2e4a39e 7425
52ce6436
PH
7426static struct value *ada_index_struct_field_1 (int *, struct value *,
7427 int, struct type *);
7428
7429
7430/* Return field #INDEX in ARG, where the index is that returned by
7431 * find_struct_field through its INDEX_P argument. Adjust the address
7432 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7433 * If found, return value, else return NULL. */
52ce6436
PH
7434
7435static struct value *
7436ada_index_struct_field (int index, struct value *arg, int offset,
7437 struct type *type)
7438{
7439 return ada_index_struct_field_1 (&index, arg, offset, type);
7440}
7441
7442
7443/* Auxiliary function for ada_index_struct_field. Like
7444 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7445 * *INDEX_P. */
52ce6436
PH
7446
7447static struct value *
7448ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7449 struct type *type)
7450{
7451 int i;
7452 type = ada_check_typedef (type);
7453
7454 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7455 {
7456 if (TYPE_FIELD_NAME (type, i) == NULL)
7457 continue;
7458 else if (ada_is_wrapper_field (type, i))
7459 {
0963b4bd 7460 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7461 ada_index_struct_field_1 (index_p, arg,
7462 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7463 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7464
52ce6436
PH
7465 if (v != NULL)
7466 return v;
7467 }
7468
7469 else if (ada_is_variant_part (type, i))
7470 {
7471 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7472 find_struct_field. */
52ce6436
PH
7473 error (_("Cannot assign this kind of variant record"));
7474 }
7475 else if (*index_p == 0)
7476 return ada_value_primitive_field (arg, offset, i, type);
7477 else
7478 *index_p -= 1;
7479 }
7480 return NULL;
7481}
7482
4c4b4cd2
PH
7483/* Given ARG, a value of type (pointer or reference to a)*
7484 structure/union, extract the component named NAME from the ultimate
7485 target structure/union and return it as a value with its
f5938064 7486 appropriate type.
14f9c5c9 7487
4c4b4cd2
PH
7488 The routine searches for NAME among all members of the structure itself
7489 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7490 (e.g., '_parent').
7491
03ee6b2e
PH
7492 If NO_ERR, then simply return NULL in case of error, rather than
7493 calling error. */
14f9c5c9 7494
d2e4a39e 7495struct value *
a121b7c1 7496ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7497{
4c4b4cd2 7498 struct type *t, *t1;
d2e4a39e 7499 struct value *v;
1f5d1570 7500 int check_tag;
14f9c5c9 7501
4c4b4cd2 7502 v = NULL;
df407dfe 7503 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7504 if (TYPE_CODE (t) == TYPE_CODE_REF)
7505 {
7506 t1 = TYPE_TARGET_TYPE (t);
7507 if (t1 == NULL)
03ee6b2e 7508 goto BadValue;
61ee279c 7509 t1 = ada_check_typedef (t1);
4c4b4cd2 7510 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7511 {
994b9211 7512 arg = coerce_ref (arg);
76a01679
JB
7513 t = t1;
7514 }
4c4b4cd2 7515 }
14f9c5c9 7516
4c4b4cd2
PH
7517 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7518 {
7519 t1 = TYPE_TARGET_TYPE (t);
7520 if (t1 == NULL)
03ee6b2e 7521 goto BadValue;
61ee279c 7522 t1 = ada_check_typedef (t1);
4c4b4cd2 7523 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7524 {
7525 arg = value_ind (arg);
7526 t = t1;
7527 }
4c4b4cd2 7528 else
76a01679 7529 break;
4c4b4cd2 7530 }
14f9c5c9 7531
4c4b4cd2 7532 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7533 goto BadValue;
14f9c5c9 7534
4c4b4cd2
PH
7535 if (t1 == t)
7536 v = ada_search_struct_field (name, arg, 0, t);
7537 else
7538 {
7539 int bit_offset, bit_size, byte_offset;
7540 struct type *field_type;
7541 CORE_ADDR address;
7542
76a01679 7543 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7544 address = value_address (ada_value_ind (arg));
4c4b4cd2 7545 else
b50d69b5 7546 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7547
828d5846
XR
7548 /* Check to see if this is a tagged type. We also need to handle
7549 the case where the type is a reference to a tagged type, but
7550 we have to be careful to exclude pointers to tagged types.
7551 The latter should be shown as usual (as a pointer), whereas
7552 a reference should mostly be transparent to the user. */
7553
7554 if (ada_is_tagged_type (t1, 0)
7555 || (TYPE_CODE (t1) == TYPE_CODE_REF
7556 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7557 {
7558 /* We first try to find the searched field in the current type.
7559 If not found then let's look in the fixed type. */
7560
7561 if (!find_struct_field (name, t1, 0,
7562 &field_type, &byte_offset, &bit_offset,
7563 &bit_size, NULL))
1f5d1570
JG
7564 check_tag = 1;
7565 else
7566 check_tag = 0;
828d5846
XR
7567 }
7568 else
1f5d1570
JG
7569 check_tag = 0;
7570
7571 /* Convert to fixed type in all cases, so that we have proper
7572 offsets to each field in unconstrained record types. */
7573 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7574 address, NULL, check_tag);
828d5846 7575
76a01679
JB
7576 if (find_struct_field (name, t1, 0,
7577 &field_type, &byte_offset, &bit_offset,
52ce6436 7578 &bit_size, NULL))
76a01679
JB
7579 {
7580 if (bit_size != 0)
7581 {
714e53ab
PH
7582 if (TYPE_CODE (t) == TYPE_CODE_REF)
7583 arg = ada_coerce_ref (arg);
7584 else
7585 arg = ada_value_ind (arg);
76a01679
JB
7586 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7587 bit_offset, bit_size,
7588 field_type);
7589 }
7590 else
f5938064 7591 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7592 }
7593 }
7594
03ee6b2e
PH
7595 if (v != NULL || no_err)
7596 return v;
7597 else
323e0a4a 7598 error (_("There is no member named %s."), name);
14f9c5c9 7599
03ee6b2e
PH
7600 BadValue:
7601 if (no_err)
7602 return NULL;
7603 else
0963b4bd
MS
7604 error (_("Attempt to extract a component of "
7605 "a value that is not a record."));
14f9c5c9
AS
7606}
7607
3b4de39c 7608/* Return a string representation of type TYPE. */
99bbb428 7609
3b4de39c 7610static std::string
99bbb428
PA
7611type_as_string (struct type *type)
7612{
d7e74731 7613 string_file tmp_stream;
99bbb428 7614
d7e74731 7615 type_print (type, "", &tmp_stream, -1);
99bbb428 7616
d7e74731 7617 return std::move (tmp_stream.string ());
99bbb428
PA
7618}
7619
14f9c5c9 7620/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7621 If DISPP is non-null, add its byte displacement from the beginning of a
7622 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7623 work for packed fields).
7624
7625 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7626 followed by "___".
14f9c5c9 7627
0963b4bd 7628 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7629 be a (pointer or reference)+ to a struct or union, and the
7630 ultimate target type will be searched.
14f9c5c9
AS
7631
7632 Looks recursively into variant clauses and parent types.
7633
828d5846
XR
7634 In the case of homonyms in the tagged types, please refer to the
7635 long explanation in find_struct_field's function documentation.
7636
4c4b4cd2
PH
7637 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7638 TYPE is not a type of the right kind. */
14f9c5c9 7639
4c4b4cd2 7640static struct type *
a121b7c1 7641ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7642 int noerr)
14f9c5c9
AS
7643{
7644 int i;
828d5846 7645 int parent_offset = -1;
14f9c5c9
AS
7646
7647 if (name == NULL)
7648 goto BadName;
7649
76a01679 7650 if (refok && type != NULL)
4c4b4cd2
PH
7651 while (1)
7652 {
61ee279c 7653 type = ada_check_typedef (type);
76a01679
JB
7654 if (TYPE_CODE (type) != TYPE_CODE_PTR
7655 && TYPE_CODE (type) != TYPE_CODE_REF)
7656 break;
7657 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7658 }
14f9c5c9 7659
76a01679 7660 if (type == NULL
1265e4aa
JB
7661 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7662 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7663 {
4c4b4cd2 7664 if (noerr)
76a01679 7665 return NULL;
99bbb428 7666
3b4de39c
PA
7667 error (_("Type %s is not a structure or union type"),
7668 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7669 }
7670
7671 type = to_static_fixed_type (type);
7672
7673 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7674 {
0d5cff50 7675 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7676 struct type *t;
d2e4a39e 7677
14f9c5c9 7678 if (t_field_name == NULL)
4c4b4cd2 7679 continue;
14f9c5c9 7680
828d5846
XR
7681 else if (ada_is_parent_field (type, i))
7682 {
7683 /* This is a field pointing us to the parent type of a tagged
7684 type. As hinted in this function's documentation, we give
7685 preference to fields in the current record first, so what
7686 we do here is just record the index of this field before
7687 we skip it. If it turns out we couldn't find our field
7688 in the current record, then we'll get back to it and search
7689 inside it whether the field might exist in the parent. */
7690
7691 parent_offset = i;
7692 continue;
7693 }
7694
14f9c5c9 7695 else if (field_name_match (t_field_name, name))
988f6b3d 7696 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7697
7698 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7699 {
4c4b4cd2 7700 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7701 0, 1);
4c4b4cd2 7702 if (t != NULL)
988f6b3d 7703 return t;
4c4b4cd2 7704 }
14f9c5c9
AS
7705
7706 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7707 {
7708 int j;
5b4ee69b
MS
7709 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7710 i));
4c4b4cd2
PH
7711
7712 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7713 {
b1f33ddd
JB
7714 /* FIXME pnh 2008/01/26: We check for a field that is
7715 NOT wrapped in a struct, since the compiler sometimes
7716 generates these for unchecked variant types. Revisit
0963b4bd 7717 if the compiler changes this practice. */
0d5cff50 7718 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7719
b1f33ddd
JB
7720 if (v_field_name != NULL
7721 && field_name_match (v_field_name, name))
460efde1 7722 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7723 else
0963b4bd
MS
7724 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7725 j),
988f6b3d 7726 name, 0, 1);
b1f33ddd 7727
4c4b4cd2 7728 if (t != NULL)
988f6b3d 7729 return t;
4c4b4cd2
PH
7730 }
7731 }
14f9c5c9
AS
7732
7733 }
7734
828d5846
XR
7735 /* Field not found so far. If this is a tagged type which
7736 has a parent, try finding that field in the parent now. */
7737
7738 if (parent_offset != -1)
7739 {
7740 struct type *t;
7741
7742 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7743 name, 0, 1);
7744 if (t != NULL)
7745 return t;
7746 }
7747
14f9c5c9 7748BadName:
d2e4a39e 7749 if (!noerr)
14f9c5c9 7750 {
2b2798cc 7751 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7752
7753 error (_("Type %s has no component named %s"),
3b4de39c 7754 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7755 }
7756
7757 return NULL;
7758}
7759
b1f33ddd
JB
7760/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7761 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7762 represents an unchecked union (that is, the variant part of a
0963b4bd 7763 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7764
7765static int
7766is_unchecked_variant (struct type *var_type, struct type *outer_type)
7767{
a121b7c1 7768 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7769
988f6b3d 7770 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7771}
7772
7773
14f9c5c9
AS
7774/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7775 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7776 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7777 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7778
d2e4a39e 7779int
ebf56fd3 7780ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7781 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7782{
7783 int others_clause;
7784 int i;
a121b7c1 7785 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7786 struct value *outer;
7787 struct value *discrim;
14f9c5c9
AS
7788 LONGEST discrim_val;
7789
012370f6
TT
7790 /* Using plain value_from_contents_and_address here causes problems
7791 because we will end up trying to resolve a type that is currently
7792 being constructed. */
7793 outer = value_from_contents_and_address_unresolved (outer_type,
7794 outer_valaddr, 0);
0c281816
JB
7795 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7796 if (discrim == NULL)
14f9c5c9 7797 return -1;
0c281816 7798 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7799
7800 others_clause = -1;
7801 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7802 {
7803 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7804 others_clause = i;
14f9c5c9 7805 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7806 return i;
14f9c5c9
AS
7807 }
7808
7809 return others_clause;
7810}
d2e4a39e 7811\f
14f9c5c9
AS
7812
7813
4c4b4cd2 7814 /* Dynamic-Sized Records */
14f9c5c9
AS
7815
7816/* Strategy: The type ostensibly attached to a value with dynamic size
7817 (i.e., a size that is not statically recorded in the debugging
7818 data) does not accurately reflect the size or layout of the value.
7819 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7820 conventional types that are constructed on the fly. */
14f9c5c9
AS
7821
7822/* There is a subtle and tricky problem here. In general, we cannot
7823 determine the size of dynamic records without its data. However,
7824 the 'struct value' data structure, which GDB uses to represent
7825 quantities in the inferior process (the target), requires the size
7826 of the type at the time of its allocation in order to reserve space
7827 for GDB's internal copy of the data. That's why the
7828 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7829 rather than struct value*s.
14f9c5c9
AS
7830
7831 However, GDB's internal history variables ($1, $2, etc.) are
7832 struct value*s containing internal copies of the data that are not, in
7833 general, the same as the data at their corresponding addresses in
7834 the target. Fortunately, the types we give to these values are all
7835 conventional, fixed-size types (as per the strategy described
7836 above), so that we don't usually have to perform the
7837 'to_fixed_xxx_type' conversions to look at their values.
7838 Unfortunately, there is one exception: if one of the internal
7839 history variables is an array whose elements are unconstrained
7840 records, then we will need to create distinct fixed types for each
7841 element selected. */
7842
7843/* The upshot of all of this is that many routines take a (type, host
7844 address, target address) triple as arguments to represent a value.
7845 The host address, if non-null, is supposed to contain an internal
7846 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7847 target at the target address. */
14f9c5c9
AS
7848
7849/* Assuming that VAL0 represents a pointer value, the result of
7850 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7851 dynamic-sized types. */
14f9c5c9 7852
d2e4a39e
AS
7853struct value *
7854ada_value_ind (struct value *val0)
14f9c5c9 7855{
c48db5ca 7856 struct value *val = value_ind (val0);
5b4ee69b 7857
b50d69b5
JG
7858 if (ada_is_tagged_type (value_type (val), 0))
7859 val = ada_tag_value_at_base_address (val);
7860
4c4b4cd2 7861 return ada_to_fixed_value (val);
14f9c5c9
AS
7862}
7863
7864/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7865 qualifiers on VAL0. */
7866
d2e4a39e
AS
7867static struct value *
7868ada_coerce_ref (struct value *val0)
7869{
df407dfe 7870 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7871 {
7872 struct value *val = val0;
5b4ee69b 7873
994b9211 7874 val = coerce_ref (val);
b50d69b5
JG
7875
7876 if (ada_is_tagged_type (value_type (val), 0))
7877 val = ada_tag_value_at_base_address (val);
7878
4c4b4cd2 7879 return ada_to_fixed_value (val);
d2e4a39e
AS
7880 }
7881 else
14f9c5c9
AS
7882 return val0;
7883}
7884
7885/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7886 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7887
7888static unsigned int
ebf56fd3 7889align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7890{
7891 return (off + alignment - 1) & ~(alignment - 1);
7892}
7893
4c4b4cd2 7894/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7895
7896static unsigned int
ebf56fd3 7897field_alignment (struct type *type, int f)
14f9c5c9 7898{
d2e4a39e 7899 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7900 int len;
14f9c5c9
AS
7901 int align_offset;
7902
64a1bf19
JB
7903 /* The field name should never be null, unless the debugging information
7904 is somehow malformed. In this case, we assume the field does not
7905 require any alignment. */
7906 if (name == NULL)
7907 return 1;
7908
7909 len = strlen (name);
7910
4c4b4cd2
PH
7911 if (!isdigit (name[len - 1]))
7912 return 1;
14f9c5c9 7913
d2e4a39e 7914 if (isdigit (name[len - 2]))
14f9c5c9
AS
7915 align_offset = len - 2;
7916 else
7917 align_offset = len - 1;
7918
61012eef 7919 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7920 return TARGET_CHAR_BIT;
7921
4c4b4cd2
PH
7922 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7923}
7924
852dff6c 7925/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7926
852dff6c
JB
7927static struct symbol *
7928ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7929{
7930 struct symbol *sym;
7931
7932 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7933 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7934 return sym;
7935
4186eb54
KS
7936 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7937 return sym;
14f9c5c9
AS
7938}
7939
dddfab26
UW
7940/* Find a type named NAME. Ignores ambiguity. This routine will look
7941 solely for types defined by debug info, it will not search the GDB
7942 primitive types. */
4c4b4cd2 7943
852dff6c 7944static struct type *
ebf56fd3 7945ada_find_any_type (const char *name)
14f9c5c9 7946{
852dff6c 7947 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7948
14f9c5c9 7949 if (sym != NULL)
dddfab26 7950 return SYMBOL_TYPE (sym);
14f9c5c9 7951
dddfab26 7952 return NULL;
14f9c5c9
AS
7953}
7954
739593e0
JB
7955/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7956 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7957 symbol, in which case it is returned. Otherwise, this looks for
7958 symbols whose name is that of NAME_SYM suffixed with "___XR".
7959 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7960
7961struct symbol *
270140bd 7962ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7963{
739593e0 7964 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7965 struct symbol *sym;
7966
739593e0
JB
7967 if (strstr (name, "___XR") != NULL)
7968 return name_sym;
7969
aeb5907d
JB
7970 sym = find_old_style_renaming_symbol (name, block);
7971
7972 if (sym != NULL)
7973 return sym;
7974
0963b4bd 7975 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7976 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7977 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7978 return sym;
7979 else
7980 return NULL;
7981}
7982
7983static struct symbol *
270140bd 7984find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7985{
7f0df278 7986 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7987 char *rename;
7988
7989 if (function_sym != NULL)
7990 {
7991 /* If the symbol is defined inside a function, NAME is not fully
7992 qualified. This means we need to prepend the function name
7993 as well as adding the ``___XR'' suffix to build the name of
7994 the associated renaming symbol. */
0d5cff50 7995 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7996 /* Function names sometimes contain suffixes used
7997 for instance to qualify nested subprograms. When building
7998 the XR type name, we need to make sure that this suffix is
7999 not included. So do not include any suffix in the function
8000 name length below. */
69fadcdf 8001 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
8002 const int rename_len = function_name_len + 2 /* "__" */
8003 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 8004
529cad9c 8005 /* Strip the suffix if necessary. */
69fadcdf
JB
8006 ada_remove_trailing_digits (function_name, &function_name_len);
8007 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8008 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 8009
4c4b4cd2
PH
8010 /* Library-level functions are a special case, as GNAT adds
8011 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 8012 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
8013 have this prefix, so we need to skip this prefix if present. */
8014 if (function_name_len > 5 /* "_ada_" */
8015 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
8016 {
8017 function_name += 5;
8018 function_name_len -= 5;
8019 }
4c4b4cd2
PH
8020
8021 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
8022 strncpy (rename, function_name, function_name_len);
8023 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8024 "__%s___XR", name);
4c4b4cd2
PH
8025 }
8026 else
8027 {
8028 const int rename_len = strlen (name) + 6;
5b4ee69b 8029
4c4b4cd2 8030 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 8031 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
8032 }
8033
852dff6c 8034 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
8035}
8036
14f9c5c9 8037/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 8038 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 8039 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
8040 otherwise return 0. */
8041
14f9c5c9 8042int
d2e4a39e 8043ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
8044{
8045 if (type1 == NULL)
8046 return 1;
8047 else if (type0 == NULL)
8048 return 0;
8049 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8050 return 1;
8051 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8052 return 0;
4c4b4cd2
PH
8053 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8054 return 1;
ad82864c 8055 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8056 return 1;
4c4b4cd2
PH
8057 else if (ada_is_array_descriptor_type (type0)
8058 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8059 return 1;
aeb5907d
JB
8060 else
8061 {
a737d952
TT
8062 const char *type0_name = TYPE_NAME (type0);
8063 const char *type1_name = TYPE_NAME (type1);
aeb5907d
JB
8064
8065 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8066 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8067 return 1;
8068 }
14f9c5c9
AS
8069 return 0;
8070}
8071
e86ca25f
TT
8072/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
8073 null. */
4c4b4cd2 8074
0d5cff50 8075const char *
d2e4a39e 8076ada_type_name (struct type *type)
14f9c5c9 8077{
d2e4a39e 8078 if (type == NULL)
14f9c5c9 8079 return NULL;
e86ca25f 8080 return TYPE_NAME (type);
14f9c5c9
AS
8081}
8082
b4ba55a1
JB
8083/* Search the list of "descriptive" types associated to TYPE for a type
8084 whose name is NAME. */
8085
8086static struct type *
8087find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8088{
931e5bc3 8089 struct type *result, *tmp;
b4ba55a1 8090
c6044dd1
JB
8091 if (ada_ignore_descriptive_types_p)
8092 return NULL;
8093
b4ba55a1
JB
8094 /* If there no descriptive-type info, then there is no parallel type
8095 to be found. */
8096 if (!HAVE_GNAT_AUX_INFO (type))
8097 return NULL;
8098
8099 result = TYPE_DESCRIPTIVE_TYPE (type);
8100 while (result != NULL)
8101 {
0d5cff50 8102 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8103
8104 if (result_name == NULL)
8105 {
8106 warning (_("unexpected null name on descriptive type"));
8107 return NULL;
8108 }
8109
8110 /* If the names match, stop. */
8111 if (strcmp (result_name, name) == 0)
8112 break;
8113
8114 /* Otherwise, look at the next item on the list, if any. */
8115 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8116 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8117 else
8118 tmp = NULL;
8119
8120 /* If not found either, try after having resolved the typedef. */
8121 if (tmp != NULL)
8122 result = tmp;
b4ba55a1 8123 else
931e5bc3 8124 {
f168693b 8125 result = check_typedef (result);
931e5bc3
JG
8126 if (HAVE_GNAT_AUX_INFO (result))
8127 result = TYPE_DESCRIPTIVE_TYPE (result);
8128 else
8129 result = NULL;
8130 }
b4ba55a1
JB
8131 }
8132
8133 /* If we didn't find a match, see whether this is a packed array. With
8134 older compilers, the descriptive type information is either absent or
8135 irrelevant when it comes to packed arrays so the above lookup fails.
8136 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8137 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8138 return ada_find_any_type (name);
8139
8140 return result;
8141}
8142
8143/* Find a parallel type to TYPE with the specified NAME, using the
8144 descriptive type taken from the debugging information, if available,
8145 and otherwise using the (slower) name-based method. */
8146
8147static struct type *
8148ada_find_parallel_type_with_name (struct type *type, const char *name)
8149{
8150 struct type *result = NULL;
8151
8152 if (HAVE_GNAT_AUX_INFO (type))
8153 result = find_parallel_type_by_descriptive_type (type, name);
8154 else
8155 result = ada_find_any_type (name);
8156
8157 return result;
8158}
8159
8160/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8161 SUFFIX to the name of TYPE. */
14f9c5c9 8162
d2e4a39e 8163struct type *
ebf56fd3 8164ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8165{
0d5cff50 8166 char *name;
fe978cb0 8167 const char *type_name = ada_type_name (type);
14f9c5c9 8168 int len;
d2e4a39e 8169
fe978cb0 8170 if (type_name == NULL)
14f9c5c9
AS
8171 return NULL;
8172
fe978cb0 8173 len = strlen (type_name);
14f9c5c9 8174
b4ba55a1 8175 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8176
fe978cb0 8177 strcpy (name, type_name);
14f9c5c9
AS
8178 strcpy (name + len, suffix);
8179
b4ba55a1 8180 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8181}
8182
14f9c5c9 8183/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8184 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8185
d2e4a39e
AS
8186static struct type *
8187dynamic_template_type (struct type *type)
14f9c5c9 8188{
61ee279c 8189 type = ada_check_typedef (type);
14f9c5c9
AS
8190
8191 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8192 || ada_type_name (type) == NULL)
14f9c5c9 8193 return NULL;
d2e4a39e 8194 else
14f9c5c9
AS
8195 {
8196 int len = strlen (ada_type_name (type));
5b4ee69b 8197
4c4b4cd2
PH
8198 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8199 return type;
14f9c5c9 8200 else
4c4b4cd2 8201 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8202 }
8203}
8204
8205/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8206 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8207
d2e4a39e
AS
8208static int
8209is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8210{
8211 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8212
d2e4a39e 8213 return name != NULL
14f9c5c9
AS
8214 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8215 && strstr (name, "___XVL") != NULL;
8216}
8217
4c4b4cd2
PH
8218/* The index of the variant field of TYPE, or -1 if TYPE does not
8219 represent a variant record type. */
14f9c5c9 8220
d2e4a39e 8221static int
4c4b4cd2 8222variant_field_index (struct type *type)
14f9c5c9
AS
8223{
8224 int f;
8225
4c4b4cd2
PH
8226 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8227 return -1;
8228
8229 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8230 {
8231 if (ada_is_variant_part (type, f))
8232 return f;
8233 }
8234 return -1;
14f9c5c9
AS
8235}
8236
4c4b4cd2
PH
8237/* A record type with no fields. */
8238
d2e4a39e 8239static struct type *
fe978cb0 8240empty_record (struct type *templ)
14f9c5c9 8241{
fe978cb0 8242 struct type *type = alloc_type_copy (templ);
5b4ee69b 8243
14f9c5c9
AS
8244 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8245 TYPE_NFIELDS (type) = 0;
8246 TYPE_FIELDS (type) = NULL;
b1f33ddd 8247 INIT_CPLUS_SPECIFIC (type);
14f9c5c9 8248 TYPE_NAME (type) = "<empty>";
14f9c5c9
AS
8249 TYPE_LENGTH (type) = 0;
8250 return type;
8251}
8252
8253/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8254 the value of type TYPE at VALADDR or ADDRESS (see comments at
8255 the beginning of this section) VAL according to GNAT conventions.
8256 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8257 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8258 an outer-level type (i.e., as opposed to a branch of a variant.) A
8259 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8260 of the variant.
14f9c5c9 8261
4c4b4cd2
PH
8262 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8263 length are not statically known are discarded. As a consequence,
8264 VALADDR, ADDRESS and DVAL0 are ignored.
8265
8266 NOTE: Limitations: For now, we assume that dynamic fields and
8267 variants occupy whole numbers of bytes. However, they need not be
8268 byte-aligned. */
8269
8270struct type *
10a2c479 8271ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8272 const gdb_byte *valaddr,
4c4b4cd2
PH
8273 CORE_ADDR address, struct value *dval0,
8274 int keep_dynamic_fields)
14f9c5c9 8275{
d2e4a39e
AS
8276 struct value *mark = value_mark ();
8277 struct value *dval;
8278 struct type *rtype;
14f9c5c9 8279 int nfields, bit_len;
4c4b4cd2 8280 int variant_field;
14f9c5c9 8281 long off;
d94e4f4f 8282 int fld_bit_len;
14f9c5c9
AS
8283 int f;
8284
4c4b4cd2
PH
8285 /* Compute the number of fields in this record type that are going
8286 to be processed: unless keep_dynamic_fields, this includes only
8287 fields whose position and length are static will be processed. */
8288 if (keep_dynamic_fields)
8289 nfields = TYPE_NFIELDS (type);
8290 else
8291 {
8292 nfields = 0;
76a01679 8293 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8294 && !ada_is_variant_part (type, nfields)
8295 && !is_dynamic_field (type, nfields))
8296 nfields++;
8297 }
8298
e9bb382b 8299 rtype = alloc_type_copy (type);
14f9c5c9
AS
8300 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8301 INIT_CPLUS_SPECIFIC (rtype);
8302 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8303 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8304 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8305 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8306 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8307 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8308
d2e4a39e
AS
8309 off = 0;
8310 bit_len = 0;
4c4b4cd2
PH
8311 variant_field = -1;
8312
14f9c5c9
AS
8313 for (f = 0; f < nfields; f += 1)
8314 {
6c038f32
PH
8315 off = align_value (off, field_alignment (type, f))
8316 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8317 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8318 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8319
d2e4a39e 8320 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8321 {
8322 variant_field = f;
d94e4f4f 8323 fld_bit_len = 0;
4c4b4cd2 8324 }
14f9c5c9 8325 else if (is_dynamic_field (type, f))
4c4b4cd2 8326 {
284614f0
JB
8327 const gdb_byte *field_valaddr = valaddr;
8328 CORE_ADDR field_address = address;
8329 struct type *field_type =
8330 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8331
4c4b4cd2 8332 if (dval0 == NULL)
b5304971
JG
8333 {
8334 /* rtype's length is computed based on the run-time
8335 value of discriminants. If the discriminants are not
8336 initialized, the type size may be completely bogus and
0963b4bd 8337 GDB may fail to allocate a value for it. So check the
b5304971 8338 size first before creating the value. */
c1b5a1a6 8339 ada_ensure_varsize_limit (rtype);
012370f6
TT
8340 /* Using plain value_from_contents_and_address here
8341 causes problems because we will end up trying to
8342 resolve a type that is currently being
8343 constructed. */
8344 dval = value_from_contents_and_address_unresolved (rtype,
8345 valaddr,
8346 address);
9f1f738a 8347 rtype = value_type (dval);
b5304971 8348 }
4c4b4cd2
PH
8349 else
8350 dval = dval0;
8351
284614f0
JB
8352 /* If the type referenced by this field is an aligner type, we need
8353 to unwrap that aligner type, because its size might not be set.
8354 Keeping the aligner type would cause us to compute the wrong
8355 size for this field, impacting the offset of the all the fields
8356 that follow this one. */
8357 if (ada_is_aligner_type (field_type))
8358 {
8359 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8360
8361 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8362 field_address = cond_offset_target (field_address, field_offset);
8363 field_type = ada_aligned_type (field_type);
8364 }
8365
8366 field_valaddr = cond_offset_host (field_valaddr,
8367 off / TARGET_CHAR_BIT);
8368 field_address = cond_offset_target (field_address,
8369 off / TARGET_CHAR_BIT);
8370
8371 /* Get the fixed type of the field. Note that, in this case,
8372 we do not want to get the real type out of the tag: if
8373 the current field is the parent part of a tagged record,
8374 we will get the tag of the object. Clearly wrong: the real
8375 type of the parent is not the real type of the child. We
8376 would end up in an infinite loop. */
8377 field_type = ada_get_base_type (field_type);
8378 field_type = ada_to_fixed_type (field_type, field_valaddr,
8379 field_address, dval, 0);
27f2a97b
JB
8380 /* If the field size is already larger than the maximum
8381 object size, then the record itself will necessarily
8382 be larger than the maximum object size. We need to make
8383 this check now, because the size might be so ridiculously
8384 large (due to an uninitialized variable in the inferior)
8385 that it would cause an overflow when adding it to the
8386 record size. */
c1b5a1a6 8387 ada_ensure_varsize_limit (field_type);
284614f0
JB
8388
8389 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8390 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8391 /* The multiplication can potentially overflow. But because
8392 the field length has been size-checked just above, and
8393 assuming that the maximum size is a reasonable value,
8394 an overflow should not happen in practice. So rather than
8395 adding overflow recovery code to this already complex code,
8396 we just assume that it's not going to happen. */
d94e4f4f 8397 fld_bit_len =
4c4b4cd2
PH
8398 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8399 }
14f9c5c9 8400 else
4c4b4cd2 8401 {
5ded5331
JB
8402 /* Note: If this field's type is a typedef, it is important
8403 to preserve the typedef layer.
8404
8405 Otherwise, we might be transforming a typedef to a fat
8406 pointer (encoding a pointer to an unconstrained array),
8407 into a basic fat pointer (encoding an unconstrained
8408 array). As both types are implemented using the same
8409 structure, the typedef is the only clue which allows us
8410 to distinguish between the two options. Stripping it
8411 would prevent us from printing this field appropriately. */
8412 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8413 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8414 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8415 fld_bit_len =
4c4b4cd2
PH
8416 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8417 else
5ded5331
JB
8418 {
8419 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8420
8421 /* We need to be careful of typedefs when computing
8422 the length of our field. If this is a typedef,
8423 get the length of the target type, not the length
8424 of the typedef. */
8425 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8426 field_type = ada_typedef_target_type (field_type);
8427
8428 fld_bit_len =
8429 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8430 }
4c4b4cd2 8431 }
14f9c5c9 8432 if (off + fld_bit_len > bit_len)
4c4b4cd2 8433 bit_len = off + fld_bit_len;
d94e4f4f 8434 off += fld_bit_len;
4c4b4cd2
PH
8435 TYPE_LENGTH (rtype) =
8436 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8437 }
4c4b4cd2
PH
8438
8439 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8440 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8441 the record. This can happen in the presence of representation
8442 clauses. */
8443 if (variant_field >= 0)
8444 {
8445 struct type *branch_type;
8446
8447 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8448
8449 if (dval0 == NULL)
9f1f738a 8450 {
012370f6
TT
8451 /* Using plain value_from_contents_and_address here causes
8452 problems because we will end up trying to resolve a type
8453 that is currently being constructed. */
8454 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8455 address);
9f1f738a
SA
8456 rtype = value_type (dval);
8457 }
4c4b4cd2
PH
8458 else
8459 dval = dval0;
8460
8461 branch_type =
8462 to_fixed_variant_branch_type
8463 (TYPE_FIELD_TYPE (type, variant_field),
8464 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8465 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8466 if (branch_type == NULL)
8467 {
8468 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8469 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8470 TYPE_NFIELDS (rtype) -= 1;
8471 }
8472 else
8473 {
8474 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8475 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8476 fld_bit_len =
8477 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8478 TARGET_CHAR_BIT;
8479 if (off + fld_bit_len > bit_len)
8480 bit_len = off + fld_bit_len;
8481 TYPE_LENGTH (rtype) =
8482 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8483 }
8484 }
8485
714e53ab
PH
8486 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8487 should contain the alignment of that record, which should be a strictly
8488 positive value. If null or negative, then something is wrong, most
8489 probably in the debug info. In that case, we don't round up the size
0963b4bd 8490 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8491 the current RTYPE length might be good enough for our purposes. */
8492 if (TYPE_LENGTH (type) <= 0)
8493 {
323e0a4a
AC
8494 if (TYPE_NAME (rtype))
8495 warning (_("Invalid type size for `%s' detected: %d."),
8496 TYPE_NAME (rtype), TYPE_LENGTH (type));
8497 else
8498 warning (_("Invalid type size for <unnamed> detected: %d."),
8499 TYPE_LENGTH (type));
714e53ab
PH
8500 }
8501 else
8502 {
8503 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8504 TYPE_LENGTH (type));
8505 }
14f9c5c9
AS
8506
8507 value_free_to_mark (mark);
d2e4a39e 8508 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8509 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8510 return rtype;
8511}
8512
4c4b4cd2
PH
8513/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8514 of 1. */
14f9c5c9 8515
d2e4a39e 8516static struct type *
fc1a4b47 8517template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8518 CORE_ADDR address, struct value *dval0)
8519{
8520 return ada_template_to_fixed_record_type_1 (type, valaddr,
8521 address, dval0, 1);
8522}
8523
8524/* An ordinary record type in which ___XVL-convention fields and
8525 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8526 static approximations, containing all possible fields. Uses
8527 no runtime values. Useless for use in values, but that's OK,
8528 since the results are used only for type determinations. Works on both
8529 structs and unions. Representation note: to save space, we memorize
8530 the result of this function in the TYPE_TARGET_TYPE of the
8531 template type. */
8532
8533static struct type *
8534template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8535{
8536 struct type *type;
8537 int nfields;
8538 int f;
8539
9e195661
PMR
8540 /* No need no do anything if the input type is already fixed. */
8541 if (TYPE_FIXED_INSTANCE (type0))
8542 return type0;
8543
8544 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8545 if (TYPE_TARGET_TYPE (type0) != NULL)
8546 return TYPE_TARGET_TYPE (type0);
8547
9e195661 8548 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8549 type = type0;
9e195661
PMR
8550 nfields = TYPE_NFIELDS (type0);
8551
8552 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8553 recompute all over next time. */
8554 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8555
8556 for (f = 0; f < nfields; f += 1)
8557 {
460efde1 8558 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8559 struct type *new_type;
14f9c5c9 8560
4c4b4cd2 8561 if (is_dynamic_field (type0, f))
460efde1
JB
8562 {
8563 field_type = ada_check_typedef (field_type);
8564 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8565 }
14f9c5c9 8566 else
f192137b 8567 new_type = static_unwrap_type (field_type);
9e195661
PMR
8568
8569 if (new_type != field_type)
8570 {
8571 /* Clone TYPE0 only the first time we get a new field type. */
8572 if (type == type0)
8573 {
8574 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8575 TYPE_CODE (type) = TYPE_CODE (type0);
8576 INIT_CPLUS_SPECIFIC (type);
8577 TYPE_NFIELDS (type) = nfields;
8578 TYPE_FIELDS (type) = (struct field *)
8579 TYPE_ALLOC (type, nfields * sizeof (struct field));
8580 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8581 sizeof (struct field) * nfields);
8582 TYPE_NAME (type) = ada_type_name (type0);
9e195661
PMR
8583 TYPE_FIXED_INSTANCE (type) = 1;
8584 TYPE_LENGTH (type) = 0;
8585 }
8586 TYPE_FIELD_TYPE (type, f) = new_type;
8587 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8588 }
14f9c5c9 8589 }
9e195661 8590
14f9c5c9
AS
8591 return type;
8592}
8593
4c4b4cd2 8594/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8595 whose address in memory is ADDRESS, returns a revision of TYPE,
8596 which should be a non-dynamic-sized record, in which the variant
8597 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8598 for discriminant values in DVAL0, which can be NULL if the record
8599 contains the necessary discriminant values. */
8600
d2e4a39e 8601static struct type *
fc1a4b47 8602to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8603 CORE_ADDR address, struct value *dval0)
14f9c5c9 8604{
d2e4a39e 8605 struct value *mark = value_mark ();
4c4b4cd2 8606 struct value *dval;
d2e4a39e 8607 struct type *rtype;
14f9c5c9
AS
8608 struct type *branch_type;
8609 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8610 int variant_field = variant_field_index (type);
14f9c5c9 8611
4c4b4cd2 8612 if (variant_field == -1)
14f9c5c9
AS
8613 return type;
8614
4c4b4cd2 8615 if (dval0 == NULL)
9f1f738a
SA
8616 {
8617 dval = value_from_contents_and_address (type, valaddr, address);
8618 type = value_type (dval);
8619 }
4c4b4cd2
PH
8620 else
8621 dval = dval0;
8622
e9bb382b 8623 rtype = alloc_type_copy (type);
14f9c5c9 8624 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8625 INIT_CPLUS_SPECIFIC (rtype);
8626 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8627 TYPE_FIELDS (rtype) =
8628 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8629 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8630 sizeof (struct field) * nfields);
14f9c5c9 8631 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8632 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8633 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8634
4c4b4cd2
PH
8635 branch_type = to_fixed_variant_branch_type
8636 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8637 cond_offset_host (valaddr,
4c4b4cd2
PH
8638 TYPE_FIELD_BITPOS (type, variant_field)
8639 / TARGET_CHAR_BIT),
d2e4a39e 8640 cond_offset_target (address,
4c4b4cd2
PH
8641 TYPE_FIELD_BITPOS (type, variant_field)
8642 / TARGET_CHAR_BIT), dval);
d2e4a39e 8643 if (branch_type == NULL)
14f9c5c9 8644 {
4c4b4cd2 8645 int f;
5b4ee69b 8646
4c4b4cd2
PH
8647 for (f = variant_field + 1; f < nfields; f += 1)
8648 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8649 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8650 }
8651 else
8652 {
4c4b4cd2
PH
8653 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8654 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8655 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8656 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8657 }
4c4b4cd2 8658 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8659
4c4b4cd2 8660 value_free_to_mark (mark);
14f9c5c9
AS
8661 return rtype;
8662}
8663
8664/* An ordinary record type (with fixed-length fields) that describes
8665 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8666 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8667 should be in DVAL, a record value; it may be NULL if the object
8668 at ADDR itself contains any necessary discriminant values.
8669 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8670 values from the record are needed. Except in the case that DVAL,
8671 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8672 unchecked) is replaced by a particular branch of the variant.
8673
8674 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8675 is questionable and may be removed. It can arise during the
8676 processing of an unconstrained-array-of-record type where all the
8677 variant branches have exactly the same size. This is because in
8678 such cases, the compiler does not bother to use the XVS convention
8679 when encoding the record. I am currently dubious of this
8680 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8681
d2e4a39e 8682static struct type *
fc1a4b47 8683to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8684 CORE_ADDR address, struct value *dval)
14f9c5c9 8685{
d2e4a39e 8686 struct type *templ_type;
14f9c5c9 8687
876cecd0 8688 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8689 return type0;
8690
d2e4a39e 8691 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8692
8693 if (templ_type != NULL)
8694 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8695 else if (variant_field_index (type0) >= 0)
8696 {
8697 if (dval == NULL && valaddr == NULL && address == 0)
8698 return type0;
8699 return to_record_with_fixed_variant_part (type0, valaddr, address,
8700 dval);
8701 }
14f9c5c9
AS
8702 else
8703 {
876cecd0 8704 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8705 return type0;
8706 }
8707
8708}
8709
8710/* An ordinary record type (with fixed-length fields) that describes
8711 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8712 union type. Any necessary discriminants' values should be in DVAL,
8713 a record value. That is, this routine selects the appropriate
8714 branch of the union at ADDR according to the discriminant value
b1f33ddd 8715 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8716 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8717
d2e4a39e 8718static struct type *
fc1a4b47 8719to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8720 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8721{
8722 int which;
d2e4a39e
AS
8723 struct type *templ_type;
8724 struct type *var_type;
14f9c5c9
AS
8725
8726 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8727 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8728 else
14f9c5c9
AS
8729 var_type = var_type0;
8730
8731 templ_type = ada_find_parallel_type (var_type, "___XVU");
8732
8733 if (templ_type != NULL)
8734 var_type = templ_type;
8735
b1f33ddd
JB
8736 if (is_unchecked_variant (var_type, value_type (dval)))
8737 return var_type0;
d2e4a39e
AS
8738 which =
8739 ada_which_variant_applies (var_type,
0fd88904 8740 value_type (dval), value_contents (dval));
14f9c5c9
AS
8741
8742 if (which < 0)
e9bb382b 8743 return empty_record (var_type);
14f9c5c9 8744 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8745 return to_fixed_record_type
d2e4a39e
AS
8746 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8747 valaddr, address, dval);
4c4b4cd2 8748 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8749 return
8750 to_fixed_record_type
8751 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8752 else
8753 return TYPE_FIELD_TYPE (var_type, which);
8754}
8755
8908fca5
JB
8756/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8757 ENCODING_TYPE, a type following the GNAT conventions for discrete
8758 type encodings, only carries redundant information. */
8759
8760static int
8761ada_is_redundant_range_encoding (struct type *range_type,
8762 struct type *encoding_type)
8763{
108d56a4 8764 const char *bounds_str;
8908fca5
JB
8765 int n;
8766 LONGEST lo, hi;
8767
8768 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8769
005e2509
JB
8770 if (TYPE_CODE (get_base_type (range_type))
8771 != TYPE_CODE (get_base_type (encoding_type)))
8772 {
8773 /* The compiler probably used a simple base type to describe
8774 the range type instead of the range's actual base type,
8775 expecting us to get the real base type from the encoding
8776 anyway. In this situation, the encoding cannot be ignored
8777 as redundant. */
8778 return 0;
8779 }
8780
8908fca5
JB
8781 if (is_dynamic_type (range_type))
8782 return 0;
8783
8784 if (TYPE_NAME (encoding_type) == NULL)
8785 return 0;
8786
8787 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8788 if (bounds_str == NULL)
8789 return 0;
8790
8791 n = 8; /* Skip "___XDLU_". */
8792 if (!ada_scan_number (bounds_str, n, &lo, &n))
8793 return 0;
8794 if (TYPE_LOW_BOUND (range_type) != lo)
8795 return 0;
8796
8797 n += 2; /* Skip the "__" separator between the two bounds. */
8798 if (!ada_scan_number (bounds_str, n, &hi, &n))
8799 return 0;
8800 if (TYPE_HIGH_BOUND (range_type) != hi)
8801 return 0;
8802
8803 return 1;
8804}
8805
8806/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8807 a type following the GNAT encoding for describing array type
8808 indices, only carries redundant information. */
8809
8810static int
8811ada_is_redundant_index_type_desc (struct type *array_type,
8812 struct type *desc_type)
8813{
8814 struct type *this_layer = check_typedef (array_type);
8815 int i;
8816
8817 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8818 {
8819 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8820 TYPE_FIELD_TYPE (desc_type, i)))
8821 return 0;
8822 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8823 }
8824
8825 return 1;
8826}
8827
14f9c5c9
AS
8828/* Assuming that TYPE0 is an array type describing the type of a value
8829 at ADDR, and that DVAL describes a record containing any
8830 discriminants used in TYPE0, returns a type for the value that
8831 contains no dynamic components (that is, no components whose sizes
8832 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8833 true, gives an error message if the resulting type's size is over
4c4b4cd2 8834 varsize_limit. */
14f9c5c9 8835
d2e4a39e
AS
8836static struct type *
8837to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8838 int ignore_too_big)
14f9c5c9 8839{
d2e4a39e
AS
8840 struct type *index_type_desc;
8841 struct type *result;
ad82864c 8842 int constrained_packed_array_p;
931e5bc3 8843 static const char *xa_suffix = "___XA";
14f9c5c9 8844
b0dd7688 8845 type0 = ada_check_typedef (type0);
284614f0 8846 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8847 return type0;
14f9c5c9 8848
ad82864c
JB
8849 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8850 if (constrained_packed_array_p)
8851 type0 = decode_constrained_packed_array_type (type0);
284614f0 8852
931e5bc3
JG
8853 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8854
8855 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8856 encoding suffixed with 'P' may still be generated. If so,
8857 it should be used to find the XA type. */
8858
8859 if (index_type_desc == NULL)
8860 {
1da0522e 8861 const char *type_name = ada_type_name (type0);
931e5bc3 8862
1da0522e 8863 if (type_name != NULL)
931e5bc3 8864 {
1da0522e 8865 const int len = strlen (type_name);
931e5bc3
JG
8866 char *name = (char *) alloca (len + strlen (xa_suffix));
8867
1da0522e 8868 if (type_name[len - 1] == 'P')
931e5bc3 8869 {
1da0522e 8870 strcpy (name, type_name);
931e5bc3
JG
8871 strcpy (name + len - 1, xa_suffix);
8872 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8873 }
8874 }
8875 }
8876
28c85d6c 8877 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8878 if (index_type_desc != NULL
8879 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8880 {
8881 /* Ignore this ___XA parallel type, as it does not bring any
8882 useful information. This allows us to avoid creating fixed
8883 versions of the array's index types, which would be identical
8884 to the original ones. This, in turn, can also help avoid
8885 the creation of fixed versions of the array itself. */
8886 index_type_desc = NULL;
8887 }
8888
14f9c5c9
AS
8889 if (index_type_desc == NULL)
8890 {
61ee279c 8891 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8892
14f9c5c9 8893 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8894 depend on the contents of the array in properly constructed
8895 debugging data. */
529cad9c
PH
8896 /* Create a fixed version of the array element type.
8897 We're not providing the address of an element here,
e1d5a0d2 8898 and thus the actual object value cannot be inspected to do
529cad9c
PH
8899 the conversion. This should not be a problem, since arrays of
8900 unconstrained objects are not allowed. In particular, all
8901 the elements of an array of a tagged type should all be of
8902 the same type specified in the debugging info. No need to
8903 consult the object tag. */
1ed6ede0 8904 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8905
284614f0
JB
8906 /* Make sure we always create a new array type when dealing with
8907 packed array types, since we're going to fix-up the array
8908 type length and element bitsize a little further down. */
ad82864c 8909 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8910 result = type0;
14f9c5c9 8911 else
e9bb382b 8912 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8913 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8914 }
8915 else
8916 {
8917 int i;
8918 struct type *elt_type0;
8919
8920 elt_type0 = type0;
8921 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8922 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8923
8924 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8925 depend on the contents of the array in properly constructed
8926 debugging data. */
529cad9c
PH
8927 /* Create a fixed version of the array element type.
8928 We're not providing the address of an element here,
e1d5a0d2 8929 and thus the actual object value cannot be inspected to do
529cad9c
PH
8930 the conversion. This should not be a problem, since arrays of
8931 unconstrained objects are not allowed. In particular, all
8932 the elements of an array of a tagged type should all be of
8933 the same type specified in the debugging info. No need to
8934 consult the object tag. */
1ed6ede0
JB
8935 result =
8936 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8937
8938 elt_type0 = type0;
14f9c5c9 8939 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8940 {
8941 struct type *range_type =
28c85d6c 8942 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8943
e9bb382b 8944 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8945 result, range_type);
1ce677a4 8946 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8947 }
d2e4a39e 8948 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8949 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8950 }
8951
2e6fda7d
JB
8952 /* We want to preserve the type name. This can be useful when
8953 trying to get the type name of a value that has already been
8954 printed (for instance, if the user did "print VAR; whatis $". */
8955 TYPE_NAME (result) = TYPE_NAME (type0);
8956
ad82864c 8957 if (constrained_packed_array_p)
284614f0
JB
8958 {
8959 /* So far, the resulting type has been created as if the original
8960 type was a regular (non-packed) array type. As a result, the
8961 bitsize of the array elements needs to be set again, and the array
8962 length needs to be recomputed based on that bitsize. */
8963 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8964 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8965
8966 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8967 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8968 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8969 TYPE_LENGTH (result)++;
8970 }
8971
876cecd0 8972 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8973 return result;
d2e4a39e 8974}
14f9c5c9
AS
8975
8976
8977/* A standard type (containing no dynamically sized components)
8978 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8979 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8980 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8981 ADDRESS or in VALADDR contains these discriminants.
8982
1ed6ede0
JB
8983 If CHECK_TAG is not null, in the case of tagged types, this function
8984 attempts to locate the object's tag and use it to compute the actual
8985 type. However, when ADDRESS is null, we cannot use it to determine the
8986 location of the tag, and therefore compute the tagged type's actual type.
8987 So we return the tagged type without consulting the tag. */
529cad9c 8988
f192137b
JB
8989static struct type *
8990ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8991 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8992{
61ee279c 8993 type = ada_check_typedef (type);
d2e4a39e
AS
8994 switch (TYPE_CODE (type))
8995 {
8996 default:
14f9c5c9 8997 return type;
d2e4a39e 8998 case TYPE_CODE_STRUCT:
4c4b4cd2 8999 {
76a01679 9000 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
9001 struct type *fixed_record_type =
9002 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 9003
529cad9c
PH
9004 /* If STATIC_TYPE is a tagged type and we know the object's address,
9005 then we can determine its tag, and compute the object's actual
0963b4bd 9006 type from there. Note that we have to use the fixed record
1ed6ede0
JB
9007 type (the parent part of the record may have dynamic fields
9008 and the way the location of _tag is expressed may depend on
9009 them). */
529cad9c 9010
1ed6ede0 9011 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 9012 {
b50d69b5
JG
9013 struct value *tag =
9014 value_tag_from_contents_and_address
9015 (fixed_record_type,
9016 valaddr,
9017 address);
9018 struct type *real_type = type_from_tag (tag);
9019 struct value *obj =
9020 value_from_contents_and_address (fixed_record_type,
9021 valaddr,
9022 address);
9f1f738a 9023 fixed_record_type = value_type (obj);
76a01679 9024 if (real_type != NULL)
b50d69b5
JG
9025 return to_fixed_record_type
9026 (real_type, NULL,
9027 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 9028 }
4af88198
JB
9029
9030 /* Check to see if there is a parallel ___XVZ variable.
9031 If there is, then it provides the actual size of our type. */
9032 else if (ada_type_name (fixed_record_type) != NULL)
9033 {
0d5cff50 9034 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
9035 char *xvz_name
9036 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 9037 bool xvz_found = false;
4af88198
JB
9038 LONGEST size;
9039
88c15c34 9040 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
eccab96d
JB
9041 TRY
9042 {
9043 xvz_found = get_int_var_value (xvz_name, size);
9044 }
9045 CATCH (except, RETURN_MASK_ERROR)
9046 {
9047 /* We found the variable, but somehow failed to read
9048 its value. Rethrow the same error, but with a little
9049 bit more information, to help the user understand
9050 what went wrong (Eg: the variable might have been
9051 optimized out). */
9052 throw_error (except.error,
9053 _("unable to read value of %s (%s)"),
9054 xvz_name, except.message);
9055 }
9056 END_CATCH
9057
9058 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
9059 {
9060 fixed_record_type = copy_type (fixed_record_type);
9061 TYPE_LENGTH (fixed_record_type) = size;
9062
9063 /* The FIXED_RECORD_TYPE may have be a stub. We have
9064 observed this when the debugging info is STABS, and
9065 apparently it is something that is hard to fix.
9066
9067 In practice, we don't need the actual type definition
9068 at all, because the presence of the XVZ variable allows us
9069 to assume that there must be a XVS type as well, which we
9070 should be able to use later, when we need the actual type
9071 definition.
9072
9073 In the meantime, pretend that the "fixed" type we are
9074 returning is NOT a stub, because this can cause trouble
9075 when using this type to create new types targeting it.
9076 Indeed, the associated creation routines often check
9077 whether the target type is a stub and will try to replace
0963b4bd 9078 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9079 might cause the new type to have the wrong size too.
9080 Consider the case of an array, for instance, where the size
9081 of the array is computed from the number of elements in
9082 our array multiplied by the size of its element. */
9083 TYPE_STUB (fixed_record_type) = 0;
9084 }
9085 }
1ed6ede0 9086 return fixed_record_type;
4c4b4cd2 9087 }
d2e4a39e 9088 case TYPE_CODE_ARRAY:
4c4b4cd2 9089 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9090 case TYPE_CODE_UNION:
9091 if (dval == NULL)
4c4b4cd2 9092 return type;
d2e4a39e 9093 else
4c4b4cd2 9094 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9095 }
14f9c5c9
AS
9096}
9097
f192137b
JB
9098/* The same as ada_to_fixed_type_1, except that it preserves the type
9099 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9100
9101 The typedef layer needs be preserved in order to differentiate between
9102 arrays and array pointers when both types are implemented using the same
9103 fat pointer. In the array pointer case, the pointer is encoded as
9104 a typedef of the pointer type. For instance, considering:
9105
9106 type String_Access is access String;
9107 S1 : String_Access := null;
9108
9109 To the debugger, S1 is defined as a typedef of type String. But
9110 to the user, it is a pointer. So if the user tries to print S1,
9111 we should not dereference the array, but print the array address
9112 instead.
9113
9114 If we didn't preserve the typedef layer, we would lose the fact that
9115 the type is to be presented as a pointer (needs de-reference before
9116 being printed). And we would also use the source-level type name. */
f192137b
JB
9117
9118struct type *
9119ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9120 CORE_ADDR address, struct value *dval, int check_tag)
9121
9122{
9123 struct type *fixed_type =
9124 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9125
96dbd2c1
JB
9126 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9127 then preserve the typedef layer.
9128
9129 Implementation note: We can only check the main-type portion of
9130 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9131 from TYPE now returns a type that has the same instance flags
9132 as TYPE. For instance, if TYPE is a "typedef const", and its
9133 target type is a "struct", then the typedef elimination will return
9134 a "const" version of the target type. See check_typedef for more
9135 details about how the typedef layer elimination is done.
9136
9137 brobecker/2010-11-19: It seems to me that the only case where it is
9138 useful to preserve the typedef layer is when dealing with fat pointers.
9139 Perhaps, we could add a check for that and preserve the typedef layer
9140 only in that situation. But this seems unecessary so far, probably
9141 because we call check_typedef/ada_check_typedef pretty much everywhere.
9142 */
f192137b 9143 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9144 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9145 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9146 return type;
9147
9148 return fixed_type;
9149}
9150
14f9c5c9 9151/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9152 TYPE0, but based on no runtime data. */
14f9c5c9 9153
d2e4a39e
AS
9154static struct type *
9155to_static_fixed_type (struct type *type0)
14f9c5c9 9156{
d2e4a39e 9157 struct type *type;
14f9c5c9
AS
9158
9159 if (type0 == NULL)
9160 return NULL;
9161
876cecd0 9162 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9163 return type0;
9164
61ee279c 9165 type0 = ada_check_typedef (type0);
d2e4a39e 9166
14f9c5c9
AS
9167 switch (TYPE_CODE (type0))
9168 {
9169 default:
9170 return type0;
9171 case TYPE_CODE_STRUCT:
9172 type = dynamic_template_type (type0);
d2e4a39e 9173 if (type != NULL)
4c4b4cd2
PH
9174 return template_to_static_fixed_type (type);
9175 else
9176 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9177 case TYPE_CODE_UNION:
9178 type = ada_find_parallel_type (type0, "___XVU");
9179 if (type != NULL)
4c4b4cd2
PH
9180 return template_to_static_fixed_type (type);
9181 else
9182 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9183 }
9184}
9185
4c4b4cd2
PH
9186/* A static approximation of TYPE with all type wrappers removed. */
9187
d2e4a39e
AS
9188static struct type *
9189static_unwrap_type (struct type *type)
14f9c5c9
AS
9190{
9191 if (ada_is_aligner_type (type))
9192 {
61ee279c 9193 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9194 if (ada_type_name (type1) == NULL)
4c4b4cd2 9195 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9196
9197 return static_unwrap_type (type1);
9198 }
d2e4a39e 9199 else
14f9c5c9 9200 {
d2e4a39e 9201 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9202
d2e4a39e 9203 if (raw_real_type == type)
4c4b4cd2 9204 return type;
14f9c5c9 9205 else
4c4b4cd2 9206 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9207 }
9208}
9209
9210/* In some cases, incomplete and private types require
4c4b4cd2 9211 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9212 type Foo;
9213 type FooP is access Foo;
9214 V: FooP;
9215 type Foo is array ...;
4c4b4cd2 9216 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9217 cross-references to such types, we instead substitute for FooP a
9218 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9219 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9220
9221/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9222 exists, otherwise TYPE. */
9223
d2e4a39e 9224struct type *
61ee279c 9225ada_check_typedef (struct type *type)
14f9c5c9 9226{
727e3d2e
JB
9227 if (type == NULL)
9228 return NULL;
9229
736ade86
XR
9230 /* If our type is an access to an unconstrained array, which is encoded
9231 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
720d1a40
JB
9232 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9233 what allows us to distinguish between fat pointers that represent
9234 array types, and fat pointers that represent array access types
9235 (in both cases, the compiler implements them as fat pointers). */
736ade86 9236 if (ada_is_access_to_unconstrained_array (type))
720d1a40
JB
9237 return type;
9238
f168693b 9239 type = check_typedef (type);
14f9c5c9 9240 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9241 || !TYPE_STUB (type)
e86ca25f 9242 || TYPE_NAME (type) == NULL)
14f9c5c9 9243 return type;
d2e4a39e 9244 else
14f9c5c9 9245 {
e86ca25f 9246 const char *name = TYPE_NAME (type);
d2e4a39e 9247 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9248
05e522ef
JB
9249 if (type1 == NULL)
9250 return type;
9251
9252 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9253 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9254 types, only for the typedef-to-array types). If that's the case,
9255 strip the typedef layer. */
9256 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9257 type1 = ada_check_typedef (type1);
9258
9259 return type1;
14f9c5c9
AS
9260 }
9261}
9262
9263/* A value representing the data at VALADDR/ADDRESS as described by
9264 type TYPE0, but with a standard (static-sized) type that correctly
9265 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9266 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9267 creation of struct values]. */
14f9c5c9 9268
4c4b4cd2
PH
9269static struct value *
9270ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9271 struct value *val0)
14f9c5c9 9272{
1ed6ede0 9273 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9274
14f9c5c9
AS
9275 if (type == type0 && val0 != NULL)
9276 return val0;
cc0e770c
JB
9277
9278 if (VALUE_LVAL (val0) != lval_memory)
9279 {
9280 /* Our value does not live in memory; it could be a convenience
9281 variable, for instance. Create a not_lval value using val0's
9282 contents. */
9283 return value_from_contents (type, value_contents (val0));
9284 }
9285
9286 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9287}
9288
9289/* A value representing VAL, but with a standard (static-sized) type
9290 that correctly describes it. Does not necessarily create a new
9291 value. */
9292
0c3acc09 9293struct value *
4c4b4cd2
PH
9294ada_to_fixed_value (struct value *val)
9295{
c48db5ca 9296 val = unwrap_value (val);
d8ce9127 9297 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
c48db5ca 9298 return val;
14f9c5c9 9299}
d2e4a39e 9300\f
14f9c5c9 9301
14f9c5c9
AS
9302/* Attributes */
9303
4c4b4cd2
PH
9304/* Table mapping attribute numbers to names.
9305 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9306
d2e4a39e 9307static const char *attribute_names[] = {
14f9c5c9
AS
9308 "<?>",
9309
d2e4a39e 9310 "first",
14f9c5c9
AS
9311 "last",
9312 "length",
9313 "image",
14f9c5c9
AS
9314 "max",
9315 "min",
4c4b4cd2
PH
9316 "modulus",
9317 "pos",
9318 "size",
9319 "tag",
14f9c5c9 9320 "val",
14f9c5c9
AS
9321 0
9322};
9323
d2e4a39e 9324const char *
4c4b4cd2 9325ada_attribute_name (enum exp_opcode n)
14f9c5c9 9326{
4c4b4cd2
PH
9327 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9328 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9329 else
9330 return attribute_names[0];
9331}
9332
4c4b4cd2 9333/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9334
4c4b4cd2
PH
9335static LONGEST
9336pos_atr (struct value *arg)
14f9c5c9 9337{
24209737
PH
9338 struct value *val = coerce_ref (arg);
9339 struct type *type = value_type (val);
aa715135 9340 LONGEST result;
14f9c5c9 9341
d2e4a39e 9342 if (!discrete_type_p (type))
323e0a4a 9343 error (_("'POS only defined on discrete types"));
14f9c5c9 9344
aa715135
JG
9345 if (!discrete_position (type, value_as_long (val), &result))
9346 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9347
aa715135 9348 return result;
4c4b4cd2
PH
9349}
9350
9351static struct value *
3cb382c9 9352value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9353{
3cb382c9 9354 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9355}
9356
4c4b4cd2 9357/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9358
d2e4a39e
AS
9359static struct value *
9360value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9361{
d2e4a39e 9362 if (!discrete_type_p (type))
323e0a4a 9363 error (_("'VAL only defined on discrete types"));
df407dfe 9364 if (!integer_type_p (value_type (arg)))
323e0a4a 9365 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9366
9367 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9368 {
9369 long pos = value_as_long (arg);
5b4ee69b 9370
14f9c5c9 9371 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9372 error (_("argument to 'VAL out of range"));
14e75d8e 9373 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9374 }
9375 else
9376 return value_from_longest (type, value_as_long (arg));
9377}
14f9c5c9 9378\f
d2e4a39e 9379
4c4b4cd2 9380 /* Evaluation */
14f9c5c9 9381
4c4b4cd2
PH
9382/* True if TYPE appears to be an Ada character type.
9383 [At the moment, this is true only for Character and Wide_Character;
9384 It is a heuristic test that could stand improvement]. */
14f9c5c9 9385
d2e4a39e
AS
9386int
9387ada_is_character_type (struct type *type)
14f9c5c9 9388{
7b9f71f2
JB
9389 const char *name;
9390
9391 /* If the type code says it's a character, then assume it really is,
9392 and don't check any further. */
9393 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9394 return 1;
9395
9396 /* Otherwise, assume it's a character type iff it is a discrete type
9397 with a known character type name. */
9398 name = ada_type_name (type);
9399 return (name != NULL
9400 && (TYPE_CODE (type) == TYPE_CODE_INT
9401 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9402 && (strcmp (name, "character") == 0
9403 || strcmp (name, "wide_character") == 0
5a517ebd 9404 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9405 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9406}
9407
4c4b4cd2 9408/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9409
9410int
ebf56fd3 9411ada_is_string_type (struct type *type)
14f9c5c9 9412{
61ee279c 9413 type = ada_check_typedef (type);
d2e4a39e 9414 if (type != NULL
14f9c5c9 9415 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9416 && (ada_is_simple_array_type (type)
9417 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9418 && ada_array_arity (type) == 1)
9419 {
9420 struct type *elttype = ada_array_element_type (type, 1);
9421
9422 return ada_is_character_type (elttype);
9423 }
d2e4a39e 9424 else
14f9c5c9
AS
9425 return 0;
9426}
9427
5bf03f13
JB
9428/* The compiler sometimes provides a parallel XVS type for a given
9429 PAD type. Normally, it is safe to follow the PAD type directly,
9430 but older versions of the compiler have a bug that causes the offset
9431 of its "F" field to be wrong. Following that field in that case
9432 would lead to incorrect results, but this can be worked around
9433 by ignoring the PAD type and using the associated XVS type instead.
9434
9435 Set to True if the debugger should trust the contents of PAD types.
9436 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9437static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9438
9439/* True if TYPE is a struct type introduced by the compiler to force the
9440 alignment of a value. Such types have a single field with a
4c4b4cd2 9441 distinctive name. */
14f9c5c9
AS
9442
9443int
ebf56fd3 9444ada_is_aligner_type (struct type *type)
14f9c5c9 9445{
61ee279c 9446 type = ada_check_typedef (type);
714e53ab 9447
5bf03f13 9448 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9449 return 0;
9450
14f9c5c9 9451 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9452 && TYPE_NFIELDS (type) == 1
9453 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9454}
9455
9456/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9457 the parallel type. */
14f9c5c9 9458
d2e4a39e
AS
9459struct type *
9460ada_get_base_type (struct type *raw_type)
14f9c5c9 9461{
d2e4a39e
AS
9462 struct type *real_type_namer;
9463 struct type *raw_real_type;
14f9c5c9
AS
9464
9465 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9466 return raw_type;
9467
284614f0
JB
9468 if (ada_is_aligner_type (raw_type))
9469 /* The encoding specifies that we should always use the aligner type.
9470 So, even if this aligner type has an associated XVS type, we should
9471 simply ignore it.
9472
9473 According to the compiler gurus, an XVS type parallel to an aligner
9474 type may exist because of a stabs limitation. In stabs, aligner
9475 types are empty because the field has a variable-sized type, and
9476 thus cannot actually be used as an aligner type. As a result,
9477 we need the associated parallel XVS type to decode the type.
9478 Since the policy in the compiler is to not change the internal
9479 representation based on the debugging info format, we sometimes
9480 end up having a redundant XVS type parallel to the aligner type. */
9481 return raw_type;
9482
14f9c5c9 9483 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9484 if (real_type_namer == NULL
14f9c5c9
AS
9485 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9486 || TYPE_NFIELDS (real_type_namer) != 1)
9487 return raw_type;
9488
f80d3ff2
JB
9489 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9490 {
9491 /* This is an older encoding form where the base type needs to be
9492 looked up by name. We prefer the newer enconding because it is
9493 more efficient. */
9494 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9495 if (raw_real_type == NULL)
9496 return raw_type;
9497 else
9498 return raw_real_type;
9499 }
9500
9501 /* The field in our XVS type is a reference to the base type. */
9502 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9503}
14f9c5c9 9504
4c4b4cd2 9505/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9506
d2e4a39e
AS
9507struct type *
9508ada_aligned_type (struct type *type)
14f9c5c9
AS
9509{
9510 if (ada_is_aligner_type (type))
9511 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9512 else
9513 return ada_get_base_type (type);
9514}
9515
9516
9517/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9518 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9519
fc1a4b47
AC
9520const gdb_byte *
9521ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9522{
d2e4a39e 9523 if (ada_is_aligner_type (type))
14f9c5c9 9524 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9525 valaddr +
9526 TYPE_FIELD_BITPOS (type,
9527 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9528 else
9529 return valaddr;
9530}
9531
4c4b4cd2
PH
9532
9533
14f9c5c9 9534/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9535 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9536const char *
9537ada_enum_name (const char *name)
14f9c5c9 9538{
4c4b4cd2
PH
9539 static char *result;
9540 static size_t result_len = 0;
e6a959d6 9541 const char *tmp;
14f9c5c9 9542
4c4b4cd2
PH
9543 /* First, unqualify the enumeration name:
9544 1. Search for the last '.' character. If we find one, then skip
177b42fe 9545 all the preceding characters, the unqualified name starts
76a01679 9546 right after that dot.
4c4b4cd2 9547 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9548 translates dots into "__". Search forward for double underscores,
9549 but stop searching when we hit an overloading suffix, which is
9550 of the form "__" followed by digits. */
4c4b4cd2 9551
c3e5cd34
PH
9552 tmp = strrchr (name, '.');
9553 if (tmp != NULL)
4c4b4cd2
PH
9554 name = tmp + 1;
9555 else
14f9c5c9 9556 {
4c4b4cd2
PH
9557 while ((tmp = strstr (name, "__")) != NULL)
9558 {
9559 if (isdigit (tmp[2]))
9560 break;
9561 else
9562 name = tmp + 2;
9563 }
14f9c5c9
AS
9564 }
9565
9566 if (name[0] == 'Q')
9567 {
14f9c5c9 9568 int v;
5b4ee69b 9569
14f9c5c9 9570 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9571 {
9572 if (sscanf (name + 2, "%x", &v) != 1)
9573 return name;
9574 }
14f9c5c9 9575 else
4c4b4cd2 9576 return name;
14f9c5c9 9577
4c4b4cd2 9578 GROW_VECT (result, result_len, 16);
14f9c5c9 9579 if (isascii (v) && isprint (v))
88c15c34 9580 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9581 else if (name[1] == 'U')
88c15c34 9582 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9583 else
88c15c34 9584 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9585
9586 return result;
9587 }
d2e4a39e 9588 else
4c4b4cd2 9589 {
c3e5cd34
PH
9590 tmp = strstr (name, "__");
9591 if (tmp == NULL)
9592 tmp = strstr (name, "$");
9593 if (tmp != NULL)
4c4b4cd2
PH
9594 {
9595 GROW_VECT (result, result_len, tmp - name + 1);
9596 strncpy (result, name, tmp - name);
9597 result[tmp - name] = '\0';
9598 return result;
9599 }
9600
9601 return name;
9602 }
14f9c5c9
AS
9603}
9604
14f9c5c9
AS
9605/* Evaluate the subexpression of EXP starting at *POS as for
9606 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9607 expression. */
14f9c5c9 9608
d2e4a39e
AS
9609static struct value *
9610evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9611{
4b27a620 9612 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9613}
9614
9615/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9616 value it wraps. */
14f9c5c9 9617
d2e4a39e
AS
9618static struct value *
9619unwrap_value (struct value *val)
14f9c5c9 9620{
df407dfe 9621 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9622
14f9c5c9
AS
9623 if (ada_is_aligner_type (type))
9624 {
de4d072f 9625 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9626 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9627
14f9c5c9 9628 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9629 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9630
9631 return unwrap_value (v);
9632 }
d2e4a39e 9633 else
14f9c5c9 9634 {
d2e4a39e 9635 struct type *raw_real_type =
61ee279c 9636 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9637
5bf03f13
JB
9638 /* If there is no parallel XVS or XVE type, then the value is
9639 already unwrapped. Return it without further modification. */
9640 if ((type == raw_real_type)
9641 && ada_find_parallel_type (type, "___XVE") == NULL)
9642 return val;
14f9c5c9 9643
d2e4a39e 9644 return
4c4b4cd2
PH
9645 coerce_unspec_val_to_type
9646 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9647 value_address (val),
1ed6ede0 9648 NULL, 1));
14f9c5c9
AS
9649 }
9650}
d2e4a39e
AS
9651
9652static struct value *
50eff16b 9653cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9654{
50eff16b
UW
9655 struct value *scale = ada_scaling_factor (value_type (arg));
9656 arg = value_cast (value_type (scale), arg);
14f9c5c9 9657
50eff16b
UW
9658 arg = value_binop (arg, scale, BINOP_MUL);
9659 return value_cast (type, arg);
14f9c5c9
AS
9660}
9661
d2e4a39e 9662static struct value *
50eff16b 9663cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9664{
50eff16b
UW
9665 if (type == value_type (arg))
9666 return arg;
5b4ee69b 9667
50eff16b
UW
9668 struct value *scale = ada_scaling_factor (type);
9669 if (ada_is_fixed_point_type (value_type (arg)))
9670 arg = cast_from_fixed (value_type (scale), arg);
9671 else
9672 arg = value_cast (value_type (scale), arg);
9673
9674 arg = value_binop (arg, scale, BINOP_DIV);
9675 return value_cast (type, arg);
14f9c5c9
AS
9676}
9677
d99dcf51
JB
9678/* Given two array types T1 and T2, return nonzero iff both arrays
9679 contain the same number of elements. */
9680
9681static int
9682ada_same_array_size_p (struct type *t1, struct type *t2)
9683{
9684 LONGEST lo1, hi1, lo2, hi2;
9685
9686 /* Get the array bounds in order to verify that the size of
9687 the two arrays match. */
9688 if (!get_array_bounds (t1, &lo1, &hi1)
9689 || !get_array_bounds (t2, &lo2, &hi2))
9690 error (_("unable to determine array bounds"));
9691
9692 /* To make things easier for size comparison, normalize a bit
9693 the case of empty arrays by making sure that the difference
9694 between upper bound and lower bound is always -1. */
9695 if (lo1 > hi1)
9696 hi1 = lo1 - 1;
9697 if (lo2 > hi2)
9698 hi2 = lo2 - 1;
9699
9700 return (hi1 - lo1 == hi2 - lo2);
9701}
9702
9703/* Assuming that VAL is an array of integrals, and TYPE represents
9704 an array with the same number of elements, but with wider integral
9705 elements, return an array "casted" to TYPE. In practice, this
9706 means that the returned array is built by casting each element
9707 of the original array into TYPE's (wider) element type. */
9708
9709static struct value *
9710ada_promote_array_of_integrals (struct type *type, struct value *val)
9711{
9712 struct type *elt_type = TYPE_TARGET_TYPE (type);
9713 LONGEST lo, hi;
9714 struct value *res;
9715 LONGEST i;
9716
9717 /* Verify that both val and type are arrays of scalars, and
9718 that the size of val's elements is smaller than the size
9719 of type's element. */
9720 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9721 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9722 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9723 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9724 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9725 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9726
9727 if (!get_array_bounds (type, &lo, &hi))
9728 error (_("unable to determine array bounds"));
9729
9730 res = allocate_value (type);
9731
9732 /* Promote each array element. */
9733 for (i = 0; i < hi - lo + 1; i++)
9734 {
9735 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9736
9737 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9738 value_contents_all (elt), TYPE_LENGTH (elt_type));
9739 }
9740
9741 return res;
9742}
9743
4c4b4cd2
PH
9744/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9745 return the converted value. */
9746
d2e4a39e
AS
9747static struct value *
9748coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9749{
df407dfe 9750 struct type *type2 = value_type (val);
5b4ee69b 9751
14f9c5c9
AS
9752 if (type == type2)
9753 return val;
9754
61ee279c
PH
9755 type2 = ada_check_typedef (type2);
9756 type = ada_check_typedef (type);
14f9c5c9 9757
d2e4a39e
AS
9758 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9759 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9760 {
9761 val = ada_value_ind (val);
df407dfe 9762 type2 = value_type (val);
14f9c5c9
AS
9763 }
9764
d2e4a39e 9765 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9766 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9767 {
d99dcf51
JB
9768 if (!ada_same_array_size_p (type, type2))
9769 error (_("cannot assign arrays of different length"));
9770
9771 if (is_integral_type (TYPE_TARGET_TYPE (type))
9772 && is_integral_type (TYPE_TARGET_TYPE (type2))
9773 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9774 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9775 {
9776 /* Allow implicit promotion of the array elements to
9777 a wider type. */
9778 return ada_promote_array_of_integrals (type, val);
9779 }
9780
9781 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9782 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9783 error (_("Incompatible types in assignment"));
04624583 9784 deprecated_set_value_type (val, type);
14f9c5c9 9785 }
d2e4a39e 9786 return val;
14f9c5c9
AS
9787}
9788
4c4b4cd2
PH
9789static struct value *
9790ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9791{
9792 struct value *val;
9793 struct type *type1, *type2;
9794 LONGEST v, v1, v2;
9795
994b9211
AC
9796 arg1 = coerce_ref (arg1);
9797 arg2 = coerce_ref (arg2);
18af8284
JB
9798 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9799 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9800
76a01679
JB
9801 if (TYPE_CODE (type1) != TYPE_CODE_INT
9802 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9803 return value_binop (arg1, arg2, op);
9804
76a01679 9805 switch (op)
4c4b4cd2
PH
9806 {
9807 case BINOP_MOD:
9808 case BINOP_DIV:
9809 case BINOP_REM:
9810 break;
9811 default:
9812 return value_binop (arg1, arg2, op);
9813 }
9814
9815 v2 = value_as_long (arg2);
9816 if (v2 == 0)
323e0a4a 9817 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9818
9819 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9820 return value_binop (arg1, arg2, op);
9821
9822 v1 = value_as_long (arg1);
9823 switch (op)
9824 {
9825 case BINOP_DIV:
9826 v = v1 / v2;
76a01679
JB
9827 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9828 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9829 break;
9830 case BINOP_REM:
9831 v = v1 % v2;
76a01679
JB
9832 if (v * v1 < 0)
9833 v -= v2;
4c4b4cd2
PH
9834 break;
9835 default:
9836 /* Should not reach this point. */
9837 v = 0;
9838 }
9839
9840 val = allocate_value (type1);
990a07ab 9841 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9842 TYPE_LENGTH (value_type (val)),
9843 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9844 return val;
9845}
9846
9847static int
9848ada_value_equal (struct value *arg1, struct value *arg2)
9849{
df407dfe
AC
9850 if (ada_is_direct_array_type (value_type (arg1))
9851 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9852 {
79e8fcaa
JB
9853 struct type *arg1_type, *arg2_type;
9854
f58b38bf
JB
9855 /* Automatically dereference any array reference before
9856 we attempt to perform the comparison. */
9857 arg1 = ada_coerce_ref (arg1);
9858 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9859
4c4b4cd2
PH
9860 arg1 = ada_coerce_to_simple_array (arg1);
9861 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9862
9863 arg1_type = ada_check_typedef (value_type (arg1));
9864 arg2_type = ada_check_typedef (value_type (arg2));
9865
9866 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9867 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9868 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9869 /* FIXME: The following works only for types whose
76a01679
JB
9870 representations use all bits (no padding or undefined bits)
9871 and do not have user-defined equality. */
79e8fcaa
JB
9872 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9873 && memcmp (value_contents (arg1), value_contents (arg2),
9874 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9875 }
9876 return value_equal (arg1, arg2);
9877}
9878
52ce6436
PH
9879/* Total number of component associations in the aggregate starting at
9880 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9881 OP_AGGREGATE. */
52ce6436
PH
9882
9883static int
9884num_component_specs (struct expression *exp, int pc)
9885{
9886 int n, m, i;
5b4ee69b 9887
52ce6436
PH
9888 m = exp->elts[pc + 1].longconst;
9889 pc += 3;
9890 n = 0;
9891 for (i = 0; i < m; i += 1)
9892 {
9893 switch (exp->elts[pc].opcode)
9894 {
9895 default:
9896 n += 1;
9897 break;
9898 case OP_CHOICES:
9899 n += exp->elts[pc + 1].longconst;
9900 break;
9901 }
9902 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9903 }
9904 return n;
9905}
9906
9907/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9908 component of LHS (a simple array or a record), updating *POS past
9909 the expression, assuming that LHS is contained in CONTAINER. Does
9910 not modify the inferior's memory, nor does it modify LHS (unless
9911 LHS == CONTAINER). */
9912
9913static void
9914assign_component (struct value *container, struct value *lhs, LONGEST index,
9915 struct expression *exp, int *pos)
9916{
9917 struct value *mark = value_mark ();
9918 struct value *elt;
0e2da9f0 9919 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9920
0e2da9f0 9921 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9922 {
22601c15
UW
9923 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9924 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9925
52ce6436
PH
9926 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9927 }
9928 else
9929 {
9930 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9931 elt = ada_to_fixed_value (elt);
52ce6436
PH
9932 }
9933
9934 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9935 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9936 else
9937 value_assign_to_component (container, elt,
9938 ada_evaluate_subexp (NULL, exp, pos,
9939 EVAL_NORMAL));
9940
9941 value_free_to_mark (mark);
9942}
9943
9944/* Assuming that LHS represents an lvalue having a record or array
9945 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9946 of that aggregate's value to LHS, advancing *POS past the
9947 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9948 lvalue containing LHS (possibly LHS itself). Does not modify
9949 the inferior's memory, nor does it modify the contents of
0963b4bd 9950 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9951
9952static struct value *
9953assign_aggregate (struct value *container,
9954 struct value *lhs, struct expression *exp,
9955 int *pos, enum noside noside)
9956{
9957 struct type *lhs_type;
9958 int n = exp->elts[*pos+1].longconst;
9959 LONGEST low_index, high_index;
9960 int num_specs;
9961 LONGEST *indices;
9962 int max_indices, num_indices;
52ce6436 9963 int i;
52ce6436
PH
9964
9965 *pos += 3;
9966 if (noside != EVAL_NORMAL)
9967 {
52ce6436
PH
9968 for (i = 0; i < n; i += 1)
9969 ada_evaluate_subexp (NULL, exp, pos, noside);
9970 return container;
9971 }
9972
9973 container = ada_coerce_ref (container);
9974 if (ada_is_direct_array_type (value_type (container)))
9975 container = ada_coerce_to_simple_array (container);
9976 lhs = ada_coerce_ref (lhs);
9977 if (!deprecated_value_modifiable (lhs))
9978 error (_("Left operand of assignment is not a modifiable lvalue."));
9979
0e2da9f0 9980 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9981 if (ada_is_direct_array_type (lhs_type))
9982 {
9983 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 9984 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9985 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9986 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9987 }
9988 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9989 {
9990 low_index = 0;
9991 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9992 }
9993 else
9994 error (_("Left-hand side must be array or record."));
9995
9996 num_specs = num_component_specs (exp, *pos - 3);
9997 max_indices = 4 * num_specs + 4;
8d749320 9998 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
9999 indices[0] = indices[1] = low_index - 1;
10000 indices[2] = indices[3] = high_index + 1;
10001 num_indices = 4;
10002
10003 for (i = 0; i < n; i += 1)
10004 {
10005 switch (exp->elts[*pos].opcode)
10006 {
1fbf5ada
JB
10007 case OP_CHOICES:
10008 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10009 &num_indices, max_indices,
10010 low_index, high_index);
10011 break;
10012 case OP_POSITIONAL:
10013 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
10014 &num_indices, max_indices,
10015 low_index, high_index);
1fbf5ada
JB
10016 break;
10017 case OP_OTHERS:
10018 if (i != n-1)
10019 error (_("Misplaced 'others' clause"));
10020 aggregate_assign_others (container, lhs, exp, pos, indices,
10021 num_indices, low_index, high_index);
10022 break;
10023 default:
10024 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
10025 }
10026 }
10027
10028 return container;
10029}
10030
10031/* Assign into the component of LHS indexed by the OP_POSITIONAL
10032 construct at *POS, updating *POS past the construct, given that
10033 the positions are relative to lower bound LOW, where HIGH is the
10034 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10035 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 10036 assign_aggregate. */
52ce6436
PH
10037static void
10038aggregate_assign_positional (struct value *container,
10039 struct value *lhs, struct expression *exp,
10040 int *pos, LONGEST *indices, int *num_indices,
10041 int max_indices, LONGEST low, LONGEST high)
10042{
10043 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10044
10045 if (ind - 1 == high)
e1d5a0d2 10046 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
10047 if (ind <= high)
10048 {
10049 add_component_interval (ind, ind, indices, num_indices, max_indices);
10050 *pos += 3;
10051 assign_component (container, lhs, ind, exp, pos);
10052 }
10053 else
10054 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10055}
10056
10057/* Assign into the components of LHS indexed by the OP_CHOICES
10058 construct at *POS, updating *POS past the construct, given that
10059 the allowable indices are LOW..HIGH. Record the indices assigned
10060 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 10061 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10062static void
10063aggregate_assign_from_choices (struct value *container,
10064 struct value *lhs, struct expression *exp,
10065 int *pos, LONGEST *indices, int *num_indices,
10066 int max_indices, LONGEST low, LONGEST high)
10067{
10068 int j;
10069 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10070 int choice_pos, expr_pc;
10071 int is_array = ada_is_direct_array_type (value_type (lhs));
10072
10073 choice_pos = *pos += 3;
10074
10075 for (j = 0; j < n_choices; j += 1)
10076 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10077 expr_pc = *pos;
10078 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10079
10080 for (j = 0; j < n_choices; j += 1)
10081 {
10082 LONGEST lower, upper;
10083 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10084
52ce6436
PH
10085 if (op == OP_DISCRETE_RANGE)
10086 {
10087 choice_pos += 1;
10088 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10089 EVAL_NORMAL));
10090 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10091 EVAL_NORMAL));
10092 }
10093 else if (is_array)
10094 {
10095 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10096 EVAL_NORMAL));
10097 upper = lower;
10098 }
10099 else
10100 {
10101 int ind;
0d5cff50 10102 const char *name;
5b4ee69b 10103
52ce6436
PH
10104 switch (op)
10105 {
10106 case OP_NAME:
10107 name = &exp->elts[choice_pos + 2].string;
10108 break;
10109 case OP_VAR_VALUE:
10110 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10111 break;
10112 default:
10113 error (_("Invalid record component association."));
10114 }
10115 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10116 ind = 0;
10117 if (! find_struct_field (name, value_type (lhs), 0,
10118 NULL, NULL, NULL, NULL, &ind))
10119 error (_("Unknown component name: %s."), name);
10120 lower = upper = ind;
10121 }
10122
10123 if (lower <= upper && (lower < low || upper > high))
10124 error (_("Index in component association out of bounds."));
10125
10126 add_component_interval (lower, upper, indices, num_indices,
10127 max_indices);
10128 while (lower <= upper)
10129 {
10130 int pos1;
5b4ee69b 10131
52ce6436
PH
10132 pos1 = expr_pc;
10133 assign_component (container, lhs, lower, exp, &pos1);
10134 lower += 1;
10135 }
10136 }
10137}
10138
10139/* Assign the value of the expression in the OP_OTHERS construct in
10140 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10141 have not been previously assigned. The index intervals already assigned
10142 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10143 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10144static void
10145aggregate_assign_others (struct value *container,
10146 struct value *lhs, struct expression *exp,
10147 int *pos, LONGEST *indices, int num_indices,
10148 LONGEST low, LONGEST high)
10149{
10150 int i;
5ce64950 10151 int expr_pc = *pos + 1;
52ce6436
PH
10152
10153 for (i = 0; i < num_indices - 2; i += 2)
10154 {
10155 LONGEST ind;
5b4ee69b 10156
52ce6436
PH
10157 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10158 {
5ce64950 10159 int localpos;
5b4ee69b 10160
5ce64950
MS
10161 localpos = expr_pc;
10162 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10163 }
10164 }
10165 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10166}
10167
10168/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10169 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10170 modifying *SIZE as needed. It is an error if *SIZE exceeds
10171 MAX_SIZE. The resulting intervals do not overlap. */
10172static void
10173add_component_interval (LONGEST low, LONGEST high,
10174 LONGEST* indices, int *size, int max_size)
10175{
10176 int i, j;
5b4ee69b 10177
52ce6436
PH
10178 for (i = 0; i < *size; i += 2) {
10179 if (high >= indices[i] && low <= indices[i + 1])
10180 {
10181 int kh;
5b4ee69b 10182
52ce6436
PH
10183 for (kh = i + 2; kh < *size; kh += 2)
10184 if (high < indices[kh])
10185 break;
10186 if (low < indices[i])
10187 indices[i] = low;
10188 indices[i + 1] = indices[kh - 1];
10189 if (high > indices[i + 1])
10190 indices[i + 1] = high;
10191 memcpy (indices + i + 2, indices + kh, *size - kh);
10192 *size -= kh - i - 2;
10193 return;
10194 }
10195 else if (high < indices[i])
10196 break;
10197 }
10198
10199 if (*size == max_size)
10200 error (_("Internal error: miscounted aggregate components."));
10201 *size += 2;
10202 for (j = *size-1; j >= i+2; j -= 1)
10203 indices[j] = indices[j - 2];
10204 indices[i] = low;
10205 indices[i + 1] = high;
10206}
10207
6e48bd2c
JB
10208/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10209 is different. */
10210
10211static struct value *
b7e22850 10212ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10213{
10214 if (type == ada_check_typedef (value_type (arg2)))
10215 return arg2;
10216
10217 if (ada_is_fixed_point_type (type))
95f39a5b 10218 return cast_to_fixed (type, arg2);
6e48bd2c
JB
10219
10220 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10221 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10222
10223 return value_cast (type, arg2);
10224}
10225
284614f0
JB
10226/* Evaluating Ada expressions, and printing their result.
10227 ------------------------------------------------------
10228
21649b50
JB
10229 1. Introduction:
10230 ----------------
10231
284614f0
JB
10232 We usually evaluate an Ada expression in order to print its value.
10233 We also evaluate an expression in order to print its type, which
10234 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10235 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10236 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10237 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10238 similar.
10239
10240 Evaluating expressions is a little more complicated for Ada entities
10241 than it is for entities in languages such as C. The main reason for
10242 this is that Ada provides types whose definition might be dynamic.
10243 One example of such types is variant records. Or another example
10244 would be an array whose bounds can only be known at run time.
10245
10246 The following description is a general guide as to what should be
10247 done (and what should NOT be done) in order to evaluate an expression
10248 involving such types, and when. This does not cover how the semantic
10249 information is encoded by GNAT as this is covered separatly. For the
10250 document used as the reference for the GNAT encoding, see exp_dbug.ads
10251 in the GNAT sources.
10252
10253 Ideally, we should embed each part of this description next to its
10254 associated code. Unfortunately, the amount of code is so vast right
10255 now that it's hard to see whether the code handling a particular
10256 situation might be duplicated or not. One day, when the code is
10257 cleaned up, this guide might become redundant with the comments
10258 inserted in the code, and we might want to remove it.
10259
21649b50
JB
10260 2. ``Fixing'' an Entity, the Simple Case:
10261 -----------------------------------------
10262
284614f0
JB
10263 When evaluating Ada expressions, the tricky issue is that they may
10264 reference entities whose type contents and size are not statically
10265 known. Consider for instance a variant record:
10266
10267 type Rec (Empty : Boolean := True) is record
10268 case Empty is
10269 when True => null;
10270 when False => Value : Integer;
10271 end case;
10272 end record;
10273 Yes : Rec := (Empty => False, Value => 1);
10274 No : Rec := (empty => True);
10275
10276 The size and contents of that record depends on the value of the
10277 descriminant (Rec.Empty). At this point, neither the debugging
10278 information nor the associated type structure in GDB are able to
10279 express such dynamic types. So what the debugger does is to create
10280 "fixed" versions of the type that applies to the specific object.
10281 We also informally refer to this opperation as "fixing" an object,
10282 which means creating its associated fixed type.
10283
10284 Example: when printing the value of variable "Yes" above, its fixed
10285 type would look like this:
10286
10287 type Rec is record
10288 Empty : Boolean;
10289 Value : Integer;
10290 end record;
10291
10292 On the other hand, if we printed the value of "No", its fixed type
10293 would become:
10294
10295 type Rec is record
10296 Empty : Boolean;
10297 end record;
10298
10299 Things become a little more complicated when trying to fix an entity
10300 with a dynamic type that directly contains another dynamic type,
10301 such as an array of variant records, for instance. There are
10302 two possible cases: Arrays, and records.
10303
21649b50
JB
10304 3. ``Fixing'' Arrays:
10305 ---------------------
10306
10307 The type structure in GDB describes an array in terms of its bounds,
10308 and the type of its elements. By design, all elements in the array
10309 have the same type and we cannot represent an array of variant elements
10310 using the current type structure in GDB. When fixing an array,
10311 we cannot fix the array element, as we would potentially need one
10312 fixed type per element of the array. As a result, the best we can do
10313 when fixing an array is to produce an array whose bounds and size
10314 are correct (allowing us to read it from memory), but without having
10315 touched its element type. Fixing each element will be done later,
10316 when (if) necessary.
10317
10318 Arrays are a little simpler to handle than records, because the same
10319 amount of memory is allocated for each element of the array, even if
1b536f04 10320 the amount of space actually used by each element differs from element
21649b50 10321 to element. Consider for instance the following array of type Rec:
284614f0
JB
10322
10323 type Rec_Array is array (1 .. 2) of Rec;
10324
1b536f04
JB
10325 The actual amount of memory occupied by each element might be different
10326 from element to element, depending on the value of their discriminant.
21649b50 10327 But the amount of space reserved for each element in the array remains
1b536f04 10328 fixed regardless. So we simply need to compute that size using
21649b50
JB
10329 the debugging information available, from which we can then determine
10330 the array size (we multiply the number of elements of the array by
10331 the size of each element).
10332
10333 The simplest case is when we have an array of a constrained element
10334 type. For instance, consider the following type declarations:
10335
10336 type Bounded_String (Max_Size : Integer) is
10337 Length : Integer;
10338 Buffer : String (1 .. Max_Size);
10339 end record;
10340 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10341
10342 In this case, the compiler describes the array as an array of
10343 variable-size elements (identified by its XVS suffix) for which
10344 the size can be read in the parallel XVZ variable.
10345
10346 In the case of an array of an unconstrained element type, the compiler
10347 wraps the array element inside a private PAD type. This type should not
10348 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10349 that we also use the adjective "aligner" in our code to designate
10350 these wrapper types.
10351
1b536f04 10352 In some cases, the size allocated for each element is statically
21649b50
JB
10353 known. In that case, the PAD type already has the correct size,
10354 and the array element should remain unfixed.
10355
10356 But there are cases when this size is not statically known.
10357 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10358
10359 type Dynamic is array (1 .. Five) of Integer;
10360 type Wrapper (Has_Length : Boolean := False) is record
10361 Data : Dynamic;
10362 case Has_Length is
10363 when True => Length : Integer;
10364 when False => null;
10365 end case;
10366 end record;
10367 type Wrapper_Array is array (1 .. 2) of Wrapper;
10368
10369 Hello : Wrapper_Array := (others => (Has_Length => True,
10370 Data => (others => 17),
10371 Length => 1));
10372
10373
10374 The debugging info would describe variable Hello as being an
10375 array of a PAD type. The size of that PAD type is not statically
10376 known, but can be determined using a parallel XVZ variable.
10377 In that case, a copy of the PAD type with the correct size should
10378 be used for the fixed array.
10379
21649b50
JB
10380 3. ``Fixing'' record type objects:
10381 ----------------------------------
10382
10383 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10384 record types. In this case, in order to compute the associated
10385 fixed type, we need to determine the size and offset of each of
10386 its components. This, in turn, requires us to compute the fixed
10387 type of each of these components.
10388
10389 Consider for instance the example:
10390
10391 type Bounded_String (Max_Size : Natural) is record
10392 Str : String (1 .. Max_Size);
10393 Length : Natural;
10394 end record;
10395 My_String : Bounded_String (Max_Size => 10);
10396
10397 In that case, the position of field "Length" depends on the size
10398 of field Str, which itself depends on the value of the Max_Size
21649b50 10399 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10400 we need to fix the type of field Str. Therefore, fixing a variant
10401 record requires us to fix each of its components.
10402
10403 However, if a component does not have a dynamic size, the component
10404 should not be fixed. In particular, fields that use a PAD type
10405 should not fixed. Here is an example where this might happen
10406 (assuming type Rec above):
10407
10408 type Container (Big : Boolean) is record
10409 First : Rec;
10410 After : Integer;
10411 case Big is
10412 when True => Another : Integer;
10413 when False => null;
10414 end case;
10415 end record;
10416 My_Container : Container := (Big => False,
10417 First => (Empty => True),
10418 After => 42);
10419
10420 In that example, the compiler creates a PAD type for component First,
10421 whose size is constant, and then positions the component After just
10422 right after it. The offset of component After is therefore constant
10423 in this case.
10424
10425 The debugger computes the position of each field based on an algorithm
10426 that uses, among other things, the actual position and size of the field
21649b50
JB
10427 preceding it. Let's now imagine that the user is trying to print
10428 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10429 end up computing the offset of field After based on the size of the
10430 fixed version of field First. And since in our example First has
10431 only one actual field, the size of the fixed type is actually smaller
10432 than the amount of space allocated to that field, and thus we would
10433 compute the wrong offset of field After.
10434
21649b50
JB
10435 To make things more complicated, we need to watch out for dynamic
10436 components of variant records (identified by the ___XVL suffix in
10437 the component name). Even if the target type is a PAD type, the size
10438 of that type might not be statically known. So the PAD type needs
10439 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10440 we might end up with the wrong size for our component. This can be
10441 observed with the following type declarations:
284614f0
JB
10442
10443 type Octal is new Integer range 0 .. 7;
10444 type Octal_Array is array (Positive range <>) of Octal;
10445 pragma Pack (Octal_Array);
10446
10447 type Octal_Buffer (Size : Positive) is record
10448 Buffer : Octal_Array (1 .. Size);
10449 Length : Integer;
10450 end record;
10451
10452 In that case, Buffer is a PAD type whose size is unset and needs
10453 to be computed by fixing the unwrapped type.
10454
21649b50
JB
10455 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10456 ----------------------------------------------------------
10457
10458 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10459 thus far, be actually fixed?
10460
10461 The answer is: Only when referencing that element. For instance
10462 when selecting one component of a record, this specific component
10463 should be fixed at that point in time. Or when printing the value
10464 of a record, each component should be fixed before its value gets
10465 printed. Similarly for arrays, the element of the array should be
10466 fixed when printing each element of the array, or when extracting
10467 one element out of that array. On the other hand, fixing should
10468 not be performed on the elements when taking a slice of an array!
10469
31432a67 10470 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10471 size of each field is that we end up also miscomputing the size
10472 of the containing type. This can have adverse results when computing
10473 the value of an entity. GDB fetches the value of an entity based
10474 on the size of its type, and thus a wrong size causes GDB to fetch
10475 the wrong amount of memory. In the case where the computed size is
10476 too small, GDB fetches too little data to print the value of our
31432a67 10477 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10478 past the buffer containing the data =:-o. */
10479
ced9779b
JB
10480/* Evaluate a subexpression of EXP, at index *POS, and return a value
10481 for that subexpression cast to TO_TYPE. Advance *POS over the
10482 subexpression. */
10483
10484static value *
10485ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10486 enum noside noside, struct type *to_type)
10487{
10488 int pc = *pos;
10489
10490 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10491 || exp->elts[pc].opcode == OP_VAR_VALUE)
10492 {
10493 (*pos) += 4;
10494
10495 value *val;
10496 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10497 {
10498 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10499 return value_zero (to_type, not_lval);
10500
10501 val = evaluate_var_msym_value (noside,
10502 exp->elts[pc + 1].objfile,
10503 exp->elts[pc + 2].msymbol);
10504 }
10505 else
10506 val = evaluate_var_value (noside,
10507 exp->elts[pc + 1].block,
10508 exp->elts[pc + 2].symbol);
10509
10510 if (noside == EVAL_SKIP)
10511 return eval_skip_value (exp);
10512
10513 val = ada_value_cast (to_type, val);
10514
10515 /* Follow the Ada language semantics that do not allow taking
10516 an address of the result of a cast (view conversion in Ada). */
10517 if (VALUE_LVAL (val) == lval_memory)
10518 {
10519 if (value_lazy (val))
10520 value_fetch_lazy (val);
10521 VALUE_LVAL (val) = not_lval;
10522 }
10523 return val;
10524 }
10525
10526 value *val = evaluate_subexp (to_type, exp, pos, noside);
10527 if (noside == EVAL_SKIP)
10528 return eval_skip_value (exp);
10529 return ada_value_cast (to_type, val);
10530}
10531
284614f0
JB
10532/* Implement the evaluate_exp routine in the exp_descriptor structure
10533 for the Ada language. */
10534
52ce6436 10535static struct value *
ebf56fd3 10536ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10537 int *pos, enum noside noside)
14f9c5c9
AS
10538{
10539 enum exp_opcode op;
b5385fc0 10540 int tem;
14f9c5c9 10541 int pc;
5ec18f2b 10542 int preeval_pos;
14f9c5c9
AS
10543 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10544 struct type *type;
52ce6436 10545 int nargs, oplen;
d2e4a39e 10546 struct value **argvec;
14f9c5c9 10547
d2e4a39e
AS
10548 pc = *pos;
10549 *pos += 1;
14f9c5c9
AS
10550 op = exp->elts[pc].opcode;
10551
d2e4a39e 10552 switch (op)
14f9c5c9
AS
10553 {
10554 default:
10555 *pos -= 1;
6e48bd2c 10556 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10557
10558 if (noside == EVAL_NORMAL)
10559 arg1 = unwrap_value (arg1);
6e48bd2c 10560
edd079d9 10561 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10562 then we need to perform the conversion manually, because
10563 evaluate_subexp_standard doesn't do it. This conversion is
10564 necessary in Ada because the different kinds of float/fixed
10565 types in Ada have different representations.
10566
10567 Similarly, we need to perform the conversion from OP_LONG
10568 ourselves. */
edd079d9 10569 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10570 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10571
10572 return arg1;
4c4b4cd2
PH
10573
10574 case OP_STRING:
10575 {
76a01679 10576 struct value *result;
5b4ee69b 10577
76a01679
JB
10578 *pos -= 1;
10579 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10580 /* The result type will have code OP_STRING, bashed there from
10581 OP_ARRAY. Bash it back. */
df407dfe
AC
10582 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10583 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10584 return result;
4c4b4cd2 10585 }
14f9c5c9
AS
10586
10587 case UNOP_CAST:
10588 (*pos) += 2;
10589 type = exp->elts[pc + 1].type;
ced9779b 10590 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10591
4c4b4cd2
PH
10592 case UNOP_QUAL:
10593 (*pos) += 2;
10594 type = exp->elts[pc + 1].type;
10595 return ada_evaluate_subexp (type, exp, pos, noside);
10596
14f9c5c9
AS
10597 case BINOP_ASSIGN:
10598 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10599 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10600 {
10601 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10602 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10603 return arg1;
10604 return ada_value_assign (arg1, arg1);
10605 }
003f3813
JB
10606 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10607 except if the lhs of our assignment is a convenience variable.
10608 In the case of assigning to a convenience variable, the lhs
10609 should be exactly the result of the evaluation of the rhs. */
10610 type = value_type (arg1);
10611 if (VALUE_LVAL (arg1) == lval_internalvar)
10612 type = NULL;
10613 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10614 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10615 return arg1;
df407dfe
AC
10616 if (ada_is_fixed_point_type (value_type (arg1)))
10617 arg2 = cast_to_fixed (value_type (arg1), arg2);
10618 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10619 error
323e0a4a 10620 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10621 else
df407dfe 10622 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10623 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10624
10625 case BINOP_ADD:
10626 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10627 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10628 if (noside == EVAL_SKIP)
4c4b4cd2 10629 goto nosideret;
2ac8a782
JB
10630 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10631 return (value_from_longest
10632 (value_type (arg1),
10633 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10634 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10635 return (value_from_longest
10636 (value_type (arg2),
10637 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10638 if ((ada_is_fixed_point_type (value_type (arg1))
10639 || ada_is_fixed_point_type (value_type (arg2)))
10640 && value_type (arg1) != value_type (arg2))
323e0a4a 10641 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10642 /* Do the addition, and cast the result to the type of the first
10643 argument. We cannot cast the result to a reference type, so if
10644 ARG1 is a reference type, find its underlying type. */
10645 type = value_type (arg1);
10646 while (TYPE_CODE (type) == TYPE_CODE_REF)
10647 type = TYPE_TARGET_TYPE (type);
f44316fa 10648 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10649 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10650
10651 case BINOP_SUB:
10652 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10653 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10654 if (noside == EVAL_SKIP)
4c4b4cd2 10655 goto nosideret;
2ac8a782
JB
10656 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10657 return (value_from_longest
10658 (value_type (arg1),
10659 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10660 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10661 return (value_from_longest
10662 (value_type (arg2),
10663 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10664 if ((ada_is_fixed_point_type (value_type (arg1))
10665 || ada_is_fixed_point_type (value_type (arg2)))
10666 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10667 error (_("Operands of fixed-point subtraction "
10668 "must have the same type"));
b7789565
JB
10669 /* Do the substraction, and cast the result to the type of the first
10670 argument. We cannot cast the result to a reference type, so if
10671 ARG1 is a reference type, find its underlying type. */
10672 type = value_type (arg1);
10673 while (TYPE_CODE (type) == TYPE_CODE_REF)
10674 type = TYPE_TARGET_TYPE (type);
f44316fa 10675 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10676 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10677
10678 case BINOP_MUL:
10679 case BINOP_DIV:
e1578042
JB
10680 case BINOP_REM:
10681 case BINOP_MOD:
14f9c5c9
AS
10682 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10683 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10684 if (noside == EVAL_SKIP)
4c4b4cd2 10685 goto nosideret;
e1578042 10686 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10687 {
10688 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10689 return value_zero (value_type (arg1), not_lval);
10690 }
14f9c5c9 10691 else
4c4b4cd2 10692 {
a53b7a21 10693 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10694 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10695 arg1 = cast_from_fixed (type, arg1);
df407dfe 10696 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10697 arg2 = cast_from_fixed (type, arg2);
f44316fa 10698 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10699 return ada_value_binop (arg1, arg2, op);
10700 }
10701
4c4b4cd2
PH
10702 case BINOP_EQUAL:
10703 case BINOP_NOTEQUAL:
14f9c5c9 10704 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10705 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10706 if (noside == EVAL_SKIP)
76a01679 10707 goto nosideret;
4c4b4cd2 10708 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10709 tem = 0;
4c4b4cd2 10710 else
f44316fa
UW
10711 {
10712 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10713 tem = ada_value_equal (arg1, arg2);
10714 }
4c4b4cd2 10715 if (op == BINOP_NOTEQUAL)
76a01679 10716 tem = !tem;
fbb06eb1
UW
10717 type = language_bool_type (exp->language_defn, exp->gdbarch);
10718 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10719
10720 case UNOP_NEG:
10721 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10722 if (noside == EVAL_SKIP)
10723 goto nosideret;
df407dfe
AC
10724 else if (ada_is_fixed_point_type (value_type (arg1)))
10725 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10726 else
f44316fa
UW
10727 {
10728 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10729 return value_neg (arg1);
10730 }
4c4b4cd2 10731
2330c6c6
JB
10732 case BINOP_LOGICAL_AND:
10733 case BINOP_LOGICAL_OR:
10734 case UNOP_LOGICAL_NOT:
000d5124
JB
10735 {
10736 struct value *val;
10737
10738 *pos -= 1;
10739 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10740 type = language_bool_type (exp->language_defn, exp->gdbarch);
10741 return value_cast (type, val);
000d5124 10742 }
2330c6c6
JB
10743
10744 case BINOP_BITWISE_AND:
10745 case BINOP_BITWISE_IOR:
10746 case BINOP_BITWISE_XOR:
000d5124
JB
10747 {
10748 struct value *val;
10749
10750 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10751 *pos = pc;
10752 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10753
10754 return value_cast (value_type (arg1), val);
10755 }
2330c6c6 10756
14f9c5c9
AS
10757 case OP_VAR_VALUE:
10758 *pos -= 1;
6799def4 10759
14f9c5c9 10760 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10761 {
10762 *pos += 4;
10763 goto nosideret;
10764 }
da5c522f
JB
10765
10766 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10767 /* Only encountered when an unresolved symbol occurs in a
10768 context other than a function call, in which case, it is
52ce6436 10769 invalid. */
323e0a4a 10770 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10771 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10772
10773 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10774 {
0c1f74cf 10775 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10776 /* Check to see if this is a tagged type. We also need to handle
10777 the case where the type is a reference to a tagged type, but
10778 we have to be careful to exclude pointers to tagged types.
10779 The latter should be shown as usual (as a pointer), whereas
10780 a reference should mostly be transparent to the user. */
10781 if (ada_is_tagged_type (type, 0)
023db19c 10782 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10783 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10784 {
10785 /* Tagged types are a little special in the fact that the real
10786 type is dynamic and can only be determined by inspecting the
10787 object's tag. This means that we need to get the object's
10788 value first (EVAL_NORMAL) and then extract the actual object
10789 type from its tag.
10790
10791 Note that we cannot skip the final step where we extract
10792 the object type from its tag, because the EVAL_NORMAL phase
10793 results in dynamic components being resolved into fixed ones.
10794 This can cause problems when trying to print the type
10795 description of tagged types whose parent has a dynamic size:
10796 We use the type name of the "_parent" component in order
10797 to print the name of the ancestor type in the type description.
10798 If that component had a dynamic size, the resolution into
10799 a fixed type would result in the loss of that type name,
10800 thus preventing us from printing the name of the ancestor
10801 type in the type description. */
10802 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10803
10804 if (TYPE_CODE (type) != TYPE_CODE_REF)
10805 {
10806 struct type *actual_type;
10807
10808 actual_type = type_from_tag (ada_value_tag (arg1));
10809 if (actual_type == NULL)
10810 /* If, for some reason, we were unable to determine
10811 the actual type from the tag, then use the static
10812 approximation that we just computed as a fallback.
10813 This can happen if the debugging information is
10814 incomplete, for instance. */
10815 actual_type = type;
10816 return value_zero (actual_type, not_lval);
10817 }
10818 else
10819 {
10820 /* In the case of a ref, ada_coerce_ref takes care
10821 of determining the actual type. But the evaluation
10822 should return a ref as it should be valid to ask
10823 for its address; so rebuild a ref after coerce. */
10824 arg1 = ada_coerce_ref (arg1);
a65cfae5 10825 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10826 }
10827 }
0c1f74cf 10828
84754697
JB
10829 /* Records and unions for which GNAT encodings have been
10830 generated need to be statically fixed as well.
10831 Otherwise, non-static fixing produces a type where
10832 all dynamic properties are removed, which prevents "ptype"
10833 from being able to completely describe the type.
10834 For instance, a case statement in a variant record would be
10835 replaced by the relevant components based on the actual
10836 value of the discriminants. */
10837 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10838 && dynamic_template_type (type) != NULL)
10839 || (TYPE_CODE (type) == TYPE_CODE_UNION
10840 && ada_find_parallel_type (type, "___XVU") != NULL))
10841 {
10842 *pos += 4;
10843 return value_zero (to_static_fixed_type (type), not_lval);
10844 }
4c4b4cd2 10845 }
da5c522f
JB
10846
10847 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10848 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10849
10850 case OP_FUNCALL:
10851 (*pos) += 2;
10852
10853 /* Allocate arg vector, including space for the function to be
10854 called in argvec[0] and a terminating NULL. */
10855 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10856 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10857
10858 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10859 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10860 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10861 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10862 else
10863 {
10864 for (tem = 0; tem <= nargs; tem += 1)
10865 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10866 argvec[tem] = 0;
10867
10868 if (noside == EVAL_SKIP)
10869 goto nosideret;
10870 }
10871
ad82864c
JB
10872 if (ada_is_constrained_packed_array_type
10873 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10874 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10875 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10876 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10877 /* This is a packed array that has already been fixed, and
10878 therefore already coerced to a simple array. Nothing further
10879 to do. */
10880 ;
e6c2c623
PMR
10881 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10882 {
10883 /* Make sure we dereference references so that all the code below
10884 feels like it's really handling the referenced value. Wrapping
10885 types (for alignment) may be there, so make sure we strip them as
10886 well. */
10887 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10888 }
10889 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10890 && VALUE_LVAL (argvec[0]) == lval_memory)
10891 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10892
df407dfe 10893 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10894
10895 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10896 them. So, if this is an array typedef (encoding use for array
10897 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10898 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10899 type = ada_typedef_target_type (type);
10900
4c4b4cd2
PH
10901 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10902 {
61ee279c 10903 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10904 {
10905 case TYPE_CODE_FUNC:
61ee279c 10906 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10907 break;
10908 case TYPE_CODE_ARRAY:
10909 break;
10910 case TYPE_CODE_STRUCT:
10911 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10912 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10913 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10914 break;
10915 default:
323e0a4a 10916 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10917 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10918 break;
10919 }
10920 }
10921
10922 switch (TYPE_CODE (type))
10923 {
10924 case TYPE_CODE_FUNC:
10925 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10926 {
7022349d
PA
10927 if (TYPE_TARGET_TYPE (type) == NULL)
10928 error_call_unknown_return_type (NULL);
10929 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10930 }
7022349d 10931 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
c8ea1972
PH
10932 case TYPE_CODE_INTERNAL_FUNCTION:
10933 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10934 /* We don't know anything about what the internal
10935 function might return, but we have to return
10936 something. */
10937 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10938 not_lval);
10939 else
10940 return call_internal_function (exp->gdbarch, exp->language_defn,
10941 argvec[0], nargs, argvec + 1);
10942
4c4b4cd2
PH
10943 case TYPE_CODE_STRUCT:
10944 {
10945 int arity;
10946
4c4b4cd2
PH
10947 arity = ada_array_arity (type);
10948 type = ada_array_element_type (type, nargs);
10949 if (type == NULL)
323e0a4a 10950 error (_("cannot subscript or call a record"));
4c4b4cd2 10951 if (arity != nargs)
323e0a4a 10952 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10953 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10954 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10955 return
10956 unwrap_value (ada_value_subscript
10957 (argvec[0], nargs, argvec + 1));
10958 }
10959 case TYPE_CODE_ARRAY:
10960 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10961 {
10962 type = ada_array_element_type (type, nargs);
10963 if (type == NULL)
323e0a4a 10964 error (_("element type of array unknown"));
4c4b4cd2 10965 else
0a07e705 10966 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10967 }
10968 return
10969 unwrap_value (ada_value_subscript
10970 (ada_coerce_to_simple_array (argvec[0]),
10971 nargs, argvec + 1));
10972 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10973 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10974 {
deede10c 10975 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10976 type = ada_array_element_type (type, nargs);
10977 if (type == NULL)
323e0a4a 10978 error (_("element type of array unknown"));
4c4b4cd2 10979 else
0a07e705 10980 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10981 }
10982 return
deede10c
JB
10983 unwrap_value (ada_value_ptr_subscript (argvec[0],
10984 nargs, argvec + 1));
4c4b4cd2
PH
10985
10986 default:
e1d5a0d2
PH
10987 error (_("Attempt to index or call something other than an "
10988 "array or function"));
4c4b4cd2
PH
10989 }
10990
10991 case TERNOP_SLICE:
10992 {
10993 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10994 struct value *low_bound_val =
10995 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10996 struct value *high_bound_val =
10997 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10998 LONGEST low_bound;
10999 LONGEST high_bound;
5b4ee69b 11000
994b9211
AC
11001 low_bound_val = coerce_ref (low_bound_val);
11002 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
11003 low_bound = value_as_long (low_bound_val);
11004 high_bound = value_as_long (high_bound_val);
963a6417 11005
4c4b4cd2
PH
11006 if (noside == EVAL_SKIP)
11007 goto nosideret;
11008
4c4b4cd2
PH
11009 /* If this is a reference to an aligner type, then remove all
11010 the aligners. */
df407dfe
AC
11011 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11012 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11013 TYPE_TARGET_TYPE (value_type (array)) =
11014 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 11015
ad82864c 11016 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 11017 error (_("cannot slice a packed array"));
4c4b4cd2
PH
11018
11019 /* If this is a reference to an array or an array lvalue,
11020 convert to a pointer. */
df407dfe
AC
11021 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11022 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
11023 && VALUE_LVAL (array) == lval_memory))
11024 array = value_addr (array);
11025
1265e4aa 11026 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 11027 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 11028 (value_type (array))))
0b5d8877 11029 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
11030
11031 array = ada_coerce_to_simple_array_ptr (array);
11032
714e53ab
PH
11033 /* If we have more than one level of pointer indirection,
11034 dereference the value until we get only one level. */
df407dfe
AC
11035 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11036 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
11037 == TYPE_CODE_PTR))
11038 array = value_ind (array);
11039
11040 /* Make sure we really do have an array type before going further,
11041 to avoid a SEGV when trying to get the index type or the target
11042 type later down the road if the debug info generated by
11043 the compiler is incorrect or incomplete. */
df407dfe 11044 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 11045 error (_("cannot take slice of non-array"));
714e53ab 11046
828292f2
JB
11047 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11048 == TYPE_CODE_PTR)
4c4b4cd2 11049 {
828292f2
JB
11050 struct type *type0 = ada_check_typedef (value_type (array));
11051
0b5d8877 11052 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 11053 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
11054 else
11055 {
11056 struct type *arr_type0 =
828292f2 11057 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 11058
f5938064
JG
11059 return ada_value_slice_from_ptr (array, arr_type0,
11060 longest_to_int (low_bound),
11061 longest_to_int (high_bound));
4c4b4cd2
PH
11062 }
11063 }
11064 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11065 return array;
11066 else if (high_bound < low_bound)
df407dfe 11067 return empty_array (value_type (array), low_bound);
4c4b4cd2 11068 else
529cad9c
PH
11069 return ada_value_slice (array, longest_to_int (low_bound),
11070 longest_to_int (high_bound));
4c4b4cd2 11071 }
14f9c5c9 11072
4c4b4cd2
PH
11073 case UNOP_IN_RANGE:
11074 (*pos) += 2;
11075 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 11076 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 11077
14f9c5c9 11078 if (noside == EVAL_SKIP)
4c4b4cd2 11079 goto nosideret;
14f9c5c9 11080
4c4b4cd2
PH
11081 switch (TYPE_CODE (type))
11082 {
11083 default:
e1d5a0d2
PH
11084 lim_warning (_("Membership test incompletely implemented; "
11085 "always returns true"));
fbb06eb1
UW
11086 type = language_bool_type (exp->language_defn, exp->gdbarch);
11087 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
11088
11089 case TYPE_CODE_RANGE:
030b4912
UW
11090 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11091 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
11092 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11093 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
11094 type = language_bool_type (exp->language_defn, exp->gdbarch);
11095 return
11096 value_from_longest (type,
4c4b4cd2
PH
11097 (value_less (arg1, arg3)
11098 || value_equal (arg1, arg3))
11099 && (value_less (arg2, arg1)
11100 || value_equal (arg2, arg1)));
11101 }
11102
11103 case BINOP_IN_BOUNDS:
14f9c5c9 11104 (*pos) += 2;
4c4b4cd2
PH
11105 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11106 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11107
4c4b4cd2
PH
11108 if (noside == EVAL_SKIP)
11109 goto nosideret;
14f9c5c9 11110
4c4b4cd2 11111 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
11112 {
11113 type = language_bool_type (exp->language_defn, exp->gdbarch);
11114 return value_zero (type, not_lval);
11115 }
14f9c5c9 11116
4c4b4cd2 11117 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11118
1eea4ebd
UW
11119 type = ada_index_type (value_type (arg2), tem, "range");
11120 if (!type)
11121 type = value_type (arg1);
14f9c5c9 11122
1eea4ebd
UW
11123 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11124 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11125
f44316fa
UW
11126 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11127 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11128 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11129 return
fbb06eb1 11130 value_from_longest (type,
4c4b4cd2
PH
11131 (value_less (arg1, arg3)
11132 || value_equal (arg1, arg3))
11133 && (value_less (arg2, arg1)
11134 || value_equal (arg2, arg1)));
11135
11136 case TERNOP_IN_RANGE:
11137 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11138 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11139 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11140
11141 if (noside == EVAL_SKIP)
11142 goto nosideret;
11143
f44316fa
UW
11144 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11145 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11146 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11147 return
fbb06eb1 11148 value_from_longest (type,
4c4b4cd2
PH
11149 (value_less (arg1, arg3)
11150 || value_equal (arg1, arg3))
11151 && (value_less (arg2, arg1)
11152 || value_equal (arg2, arg1)));
11153
11154 case OP_ATR_FIRST:
11155 case OP_ATR_LAST:
11156 case OP_ATR_LENGTH:
11157 {
76a01679 11158 struct type *type_arg;
5b4ee69b 11159
76a01679
JB
11160 if (exp->elts[*pos].opcode == OP_TYPE)
11161 {
11162 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11163 arg1 = NULL;
5bc23cb3 11164 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11165 }
11166 else
11167 {
11168 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11169 type_arg = NULL;
11170 }
11171
11172 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11173 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11174 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11175 *pos += 4;
11176
11177 if (noside == EVAL_SKIP)
11178 goto nosideret;
11179
11180 if (type_arg == NULL)
11181 {
11182 arg1 = ada_coerce_ref (arg1);
11183
ad82864c 11184 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11185 arg1 = ada_coerce_to_simple_array (arg1);
11186
aa4fb036 11187 if (op == OP_ATR_LENGTH)
1eea4ebd 11188 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11189 else
11190 {
11191 type = ada_index_type (value_type (arg1), tem,
11192 ada_attribute_name (op));
11193 if (type == NULL)
11194 type = builtin_type (exp->gdbarch)->builtin_int;
11195 }
76a01679
JB
11196
11197 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11198 return allocate_value (type);
76a01679
JB
11199
11200 switch (op)
11201 {
11202 default: /* Should never happen. */
323e0a4a 11203 error (_("unexpected attribute encountered"));
76a01679 11204 case OP_ATR_FIRST:
1eea4ebd
UW
11205 return value_from_longest
11206 (type, ada_array_bound (arg1, tem, 0));
76a01679 11207 case OP_ATR_LAST:
1eea4ebd
UW
11208 return value_from_longest
11209 (type, ada_array_bound (arg1, tem, 1));
76a01679 11210 case OP_ATR_LENGTH:
1eea4ebd
UW
11211 return value_from_longest
11212 (type, ada_array_length (arg1, tem));
76a01679
JB
11213 }
11214 }
11215 else if (discrete_type_p (type_arg))
11216 {
11217 struct type *range_type;
0d5cff50 11218 const char *name = ada_type_name (type_arg);
5b4ee69b 11219
76a01679
JB
11220 range_type = NULL;
11221 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11222 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11223 if (range_type == NULL)
11224 range_type = type_arg;
11225 switch (op)
11226 {
11227 default:
323e0a4a 11228 error (_("unexpected attribute encountered"));
76a01679 11229 case OP_ATR_FIRST:
690cc4eb 11230 return value_from_longest
43bbcdc2 11231 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11232 case OP_ATR_LAST:
690cc4eb 11233 return value_from_longest
43bbcdc2 11234 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11235 case OP_ATR_LENGTH:
323e0a4a 11236 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11237 }
11238 }
11239 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11240 error (_("unimplemented type attribute"));
76a01679
JB
11241 else
11242 {
11243 LONGEST low, high;
11244
ad82864c
JB
11245 if (ada_is_constrained_packed_array_type (type_arg))
11246 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11247
aa4fb036 11248 if (op == OP_ATR_LENGTH)
1eea4ebd 11249 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11250 else
11251 {
11252 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11253 if (type == NULL)
11254 type = builtin_type (exp->gdbarch)->builtin_int;
11255 }
1eea4ebd 11256
76a01679
JB
11257 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11258 return allocate_value (type);
11259
11260 switch (op)
11261 {
11262 default:
323e0a4a 11263 error (_("unexpected attribute encountered"));
76a01679 11264 case OP_ATR_FIRST:
1eea4ebd 11265 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11266 return value_from_longest (type, low);
11267 case OP_ATR_LAST:
1eea4ebd 11268 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11269 return value_from_longest (type, high);
11270 case OP_ATR_LENGTH:
1eea4ebd
UW
11271 low = ada_array_bound_from_type (type_arg, tem, 0);
11272 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11273 return value_from_longest (type, high - low + 1);
11274 }
11275 }
14f9c5c9
AS
11276 }
11277
4c4b4cd2
PH
11278 case OP_ATR_TAG:
11279 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11280 if (noside == EVAL_SKIP)
76a01679 11281 goto nosideret;
4c4b4cd2
PH
11282
11283 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11284 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11285
11286 return ada_value_tag (arg1);
11287
11288 case OP_ATR_MIN:
11289 case OP_ATR_MAX:
11290 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11291 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11292 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11293 if (noside == EVAL_SKIP)
76a01679 11294 goto nosideret;
d2e4a39e 11295 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11296 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11297 else
f44316fa
UW
11298 {
11299 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11300 return value_binop (arg1, arg2,
11301 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11302 }
14f9c5c9 11303
4c4b4cd2
PH
11304 case OP_ATR_MODULUS:
11305 {
31dedfee 11306 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11307
5b4ee69b 11308 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11309 if (noside == EVAL_SKIP)
11310 goto nosideret;
4c4b4cd2 11311
76a01679 11312 if (!ada_is_modular_type (type_arg))
323e0a4a 11313 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11314
76a01679
JB
11315 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11316 ada_modulus (type_arg));
4c4b4cd2
PH
11317 }
11318
11319
11320 case OP_ATR_POS:
11321 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11322 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11323 if (noside == EVAL_SKIP)
76a01679 11324 goto nosideret;
3cb382c9
UW
11325 type = builtin_type (exp->gdbarch)->builtin_int;
11326 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11327 return value_zero (type, not_lval);
14f9c5c9 11328 else
3cb382c9 11329 return value_pos_atr (type, arg1);
14f9c5c9 11330
4c4b4cd2
PH
11331 case OP_ATR_SIZE:
11332 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11333 type = value_type (arg1);
11334
11335 /* If the argument is a reference, then dereference its type, since
11336 the user is really asking for the size of the actual object,
11337 not the size of the pointer. */
11338 if (TYPE_CODE (type) == TYPE_CODE_REF)
11339 type = TYPE_TARGET_TYPE (type);
11340
4c4b4cd2 11341 if (noside == EVAL_SKIP)
76a01679 11342 goto nosideret;
4c4b4cd2 11343 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11344 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11345 else
22601c15 11346 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11347 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11348
11349 case OP_ATR_VAL:
11350 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11351 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11352 type = exp->elts[pc + 2].type;
14f9c5c9 11353 if (noside == EVAL_SKIP)
76a01679 11354 goto nosideret;
4c4b4cd2 11355 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11356 return value_zero (type, not_lval);
4c4b4cd2 11357 else
76a01679 11358 return value_val_atr (type, arg1);
4c4b4cd2
PH
11359
11360 case BINOP_EXP:
11361 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11362 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11363 if (noside == EVAL_SKIP)
11364 goto nosideret;
11365 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11366 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11367 else
f44316fa
UW
11368 {
11369 /* For integer exponentiation operations,
11370 only promote the first argument. */
11371 if (is_integral_type (value_type (arg2)))
11372 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11373 else
11374 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11375
11376 return value_binop (arg1, arg2, op);
11377 }
4c4b4cd2
PH
11378
11379 case UNOP_PLUS:
11380 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11381 if (noside == EVAL_SKIP)
11382 goto nosideret;
11383 else
11384 return arg1;
11385
11386 case UNOP_ABS:
11387 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11388 if (noside == EVAL_SKIP)
11389 goto nosideret;
f44316fa 11390 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11391 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11392 return value_neg (arg1);
14f9c5c9 11393 else
4c4b4cd2 11394 return arg1;
14f9c5c9
AS
11395
11396 case UNOP_IND:
5ec18f2b 11397 preeval_pos = *pos;
6b0d7253 11398 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11399 if (noside == EVAL_SKIP)
4c4b4cd2 11400 goto nosideret;
df407dfe 11401 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11402 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11403 {
11404 if (ada_is_array_descriptor_type (type))
11405 /* GDB allows dereferencing GNAT array descriptors. */
11406 {
11407 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11408
4c4b4cd2 11409 if (arrType == NULL)
323e0a4a 11410 error (_("Attempt to dereference null array pointer."));
00a4c844 11411 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11412 }
11413 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11414 || TYPE_CODE (type) == TYPE_CODE_REF
11415 /* In C you can dereference an array to get the 1st elt. */
11416 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11417 {
5ec18f2b
JG
11418 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11419 only be determined by inspecting the object's tag.
11420 This means that we need to evaluate completely the
11421 expression in order to get its type. */
11422
023db19c
JB
11423 if ((TYPE_CODE (type) == TYPE_CODE_REF
11424 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11425 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11426 {
11427 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11428 EVAL_NORMAL);
11429 type = value_type (ada_value_ind (arg1));
11430 }
11431 else
11432 {
11433 type = to_static_fixed_type
11434 (ada_aligned_type
11435 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11436 }
c1b5a1a6 11437 ada_ensure_varsize_limit (type);
714e53ab
PH
11438 return value_zero (type, lval_memory);
11439 }
4c4b4cd2 11440 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11441 {
11442 /* GDB allows dereferencing an int. */
11443 if (expect_type == NULL)
11444 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11445 lval_memory);
11446 else
11447 {
11448 expect_type =
11449 to_static_fixed_type (ada_aligned_type (expect_type));
11450 return value_zero (expect_type, lval_memory);
11451 }
11452 }
4c4b4cd2 11453 else
323e0a4a 11454 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11455 }
0963b4bd 11456 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11457 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11458
96967637
JB
11459 if (TYPE_CODE (type) == TYPE_CODE_INT)
11460 /* GDB allows dereferencing an int. If we were given
11461 the expect_type, then use that as the target type.
11462 Otherwise, assume that the target type is an int. */
11463 {
11464 if (expect_type != NULL)
11465 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11466 arg1));
11467 else
11468 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11469 (CORE_ADDR) value_as_address (arg1));
11470 }
6b0d7253 11471
4c4b4cd2
PH
11472 if (ada_is_array_descriptor_type (type))
11473 /* GDB allows dereferencing GNAT array descriptors. */
11474 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11475 else
4c4b4cd2 11476 return ada_value_ind (arg1);
14f9c5c9
AS
11477
11478 case STRUCTOP_STRUCT:
11479 tem = longest_to_int (exp->elts[pc + 1].longconst);
11480 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11481 preeval_pos = *pos;
14f9c5c9
AS
11482 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11483 if (noside == EVAL_SKIP)
4c4b4cd2 11484 goto nosideret;
14f9c5c9 11485 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11486 {
df407dfe 11487 struct type *type1 = value_type (arg1);
5b4ee69b 11488
76a01679
JB
11489 if (ada_is_tagged_type (type1, 1))
11490 {
11491 type = ada_lookup_struct_elt_type (type1,
11492 &exp->elts[pc + 2].string,
988f6b3d 11493 1, 1);
5ec18f2b
JG
11494
11495 /* If the field is not found, check if it exists in the
11496 extension of this object's type. This means that we
11497 need to evaluate completely the expression. */
11498
76a01679 11499 if (type == NULL)
5ec18f2b
JG
11500 {
11501 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11502 EVAL_NORMAL);
11503 arg1 = ada_value_struct_elt (arg1,
11504 &exp->elts[pc + 2].string,
11505 0);
11506 arg1 = unwrap_value (arg1);
11507 type = value_type (ada_to_fixed_value (arg1));
11508 }
76a01679
JB
11509 }
11510 else
11511 type =
11512 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11513 0);
76a01679
JB
11514
11515 return value_zero (ada_aligned_type (type), lval_memory);
11516 }
14f9c5c9 11517 else
a579cd9a
MW
11518 {
11519 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11520 arg1 = unwrap_value (arg1);
11521 return ada_to_fixed_value (arg1);
11522 }
284614f0 11523
14f9c5c9 11524 case OP_TYPE:
4c4b4cd2
PH
11525 /* The value is not supposed to be used. This is here to make it
11526 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11527 (*pos) += 2;
11528 if (noside == EVAL_SKIP)
4c4b4cd2 11529 goto nosideret;
14f9c5c9 11530 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11531 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11532 else
323e0a4a 11533 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11534
11535 case OP_AGGREGATE:
11536 case OP_CHOICES:
11537 case OP_OTHERS:
11538 case OP_DISCRETE_RANGE:
11539 case OP_POSITIONAL:
11540 case OP_NAME:
11541 if (noside == EVAL_NORMAL)
11542 switch (op)
11543 {
11544 case OP_NAME:
11545 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11546 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11547 case OP_AGGREGATE:
11548 error (_("Aggregates only allowed on the right of an assignment"));
11549 default:
0963b4bd
MS
11550 internal_error (__FILE__, __LINE__,
11551 _("aggregate apparently mangled"));
52ce6436
PH
11552 }
11553
11554 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11555 *pos += oplen - 1;
11556 for (tem = 0; tem < nargs; tem += 1)
11557 ada_evaluate_subexp (NULL, exp, pos, noside);
11558 goto nosideret;
14f9c5c9
AS
11559 }
11560
11561nosideret:
ced9779b 11562 return eval_skip_value (exp);
14f9c5c9 11563}
14f9c5c9 11564\f
d2e4a39e 11565
4c4b4cd2 11566 /* Fixed point */
14f9c5c9
AS
11567
11568/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11569 type name that encodes the 'small and 'delta information.
4c4b4cd2 11570 Otherwise, return NULL. */
14f9c5c9 11571
d2e4a39e 11572static const char *
ebf56fd3 11573fixed_type_info (struct type *type)
14f9c5c9 11574{
d2e4a39e 11575 const char *name = ada_type_name (type);
14f9c5c9
AS
11576 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11577
d2e4a39e
AS
11578 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11579 {
14f9c5c9 11580 const char *tail = strstr (name, "___XF_");
5b4ee69b 11581
14f9c5c9 11582 if (tail == NULL)
4c4b4cd2 11583 return NULL;
d2e4a39e 11584 else
4c4b4cd2 11585 return tail + 5;
14f9c5c9
AS
11586 }
11587 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11588 return fixed_type_info (TYPE_TARGET_TYPE (type));
11589 else
11590 return NULL;
11591}
11592
4c4b4cd2 11593/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11594
11595int
ebf56fd3 11596ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11597{
11598 return fixed_type_info (type) != NULL;
11599}
11600
4c4b4cd2
PH
11601/* Return non-zero iff TYPE represents a System.Address type. */
11602
11603int
11604ada_is_system_address_type (struct type *type)
11605{
11606 return (TYPE_NAME (type)
11607 && strcmp (TYPE_NAME (type), "system__address") == 0);
11608}
11609
14f9c5c9 11610/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11611 type, return the target floating-point type to be used to represent
11612 of this type during internal computation. */
11613
11614static struct type *
11615ada_scaling_type (struct type *type)
11616{
11617 return builtin_type (get_type_arch (type))->builtin_long_double;
11618}
11619
11620/* Assuming that TYPE is the representation of an Ada fixed-point
11621 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11622 delta cannot be determined. */
14f9c5c9 11623
50eff16b 11624struct value *
ebf56fd3 11625ada_delta (struct type *type)
14f9c5c9
AS
11626{
11627 const char *encoding = fixed_type_info (type);
50eff16b
UW
11628 struct type *scale_type = ada_scaling_type (type);
11629
11630 long long num, den;
11631
11632 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11633 return nullptr;
d2e4a39e 11634 else
50eff16b
UW
11635 return value_binop (value_from_longest (scale_type, num),
11636 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11637}
11638
11639/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11640 factor ('SMALL value) associated with the type. */
14f9c5c9 11641
50eff16b
UW
11642struct value *
11643ada_scaling_factor (struct type *type)
14f9c5c9
AS
11644{
11645 const char *encoding = fixed_type_info (type);
50eff16b
UW
11646 struct type *scale_type = ada_scaling_type (type);
11647
11648 long long num0, den0, num1, den1;
14f9c5c9 11649 int n;
d2e4a39e 11650
50eff16b 11651 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11652 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11653
11654 if (n < 2)
50eff16b 11655 return value_from_longest (scale_type, 1);
14f9c5c9 11656 else if (n == 4)
50eff16b
UW
11657 return value_binop (value_from_longest (scale_type, num1),
11658 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11659 else
50eff16b
UW
11660 return value_binop (value_from_longest (scale_type, num0),
11661 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11662}
11663
14f9c5c9 11664\f
d2e4a39e 11665
4c4b4cd2 11666 /* Range types */
14f9c5c9
AS
11667
11668/* Scan STR beginning at position K for a discriminant name, and
11669 return the value of that discriminant field of DVAL in *PX. If
11670 PNEW_K is not null, put the position of the character beyond the
11671 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11672 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11673
11674static int
108d56a4 11675scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11676 int *pnew_k)
14f9c5c9
AS
11677{
11678 static char *bound_buffer = NULL;
11679 static size_t bound_buffer_len = 0;
5da1a4d3 11680 const char *pstart, *pend, *bound;
d2e4a39e 11681 struct value *bound_val;
14f9c5c9
AS
11682
11683 if (dval == NULL || str == NULL || str[k] == '\0')
11684 return 0;
11685
5da1a4d3
SM
11686 pstart = str + k;
11687 pend = strstr (pstart, "__");
14f9c5c9
AS
11688 if (pend == NULL)
11689 {
5da1a4d3 11690 bound = pstart;
14f9c5c9
AS
11691 k += strlen (bound);
11692 }
d2e4a39e 11693 else
14f9c5c9 11694 {
5da1a4d3
SM
11695 int len = pend - pstart;
11696
11697 /* Strip __ and beyond. */
11698 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11699 strncpy (bound_buffer, pstart, len);
11700 bound_buffer[len] = '\0';
11701
14f9c5c9 11702 bound = bound_buffer;
d2e4a39e 11703 k = pend - str;
14f9c5c9 11704 }
d2e4a39e 11705
df407dfe 11706 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11707 if (bound_val == NULL)
11708 return 0;
11709
11710 *px = value_as_long (bound_val);
11711 if (pnew_k != NULL)
11712 *pnew_k = k;
11713 return 1;
11714}
11715
11716/* Value of variable named NAME in the current environment. If
11717 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11718 otherwise causes an error with message ERR_MSG. */
11719
d2e4a39e 11720static struct value *
edb0c9cb 11721get_var_value (const char *name, const char *err_msg)
14f9c5c9 11722{
b5ec771e 11723 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11724
54d343a2 11725 std::vector<struct block_symbol> syms;
b5ec771e
PA
11726 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11727 get_selected_block (0),
11728 VAR_DOMAIN, &syms, 1);
14f9c5c9
AS
11729
11730 if (nsyms != 1)
11731 {
11732 if (err_msg == NULL)
4c4b4cd2 11733 return 0;
14f9c5c9 11734 else
8a3fe4f8 11735 error (("%s"), err_msg);
14f9c5c9
AS
11736 }
11737
54d343a2 11738 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11739}
d2e4a39e 11740
edb0c9cb
PA
11741/* Value of integer variable named NAME in the current environment.
11742 If no such variable is found, returns false. Otherwise, sets VALUE
11743 to the variable's value and returns true. */
4c4b4cd2 11744
edb0c9cb
PA
11745bool
11746get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11747{
4c4b4cd2 11748 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11749
14f9c5c9 11750 if (var_val == 0)
edb0c9cb
PA
11751 return false;
11752
11753 value = value_as_long (var_val);
11754 return true;
14f9c5c9 11755}
d2e4a39e 11756
14f9c5c9
AS
11757
11758/* Return a range type whose base type is that of the range type named
11759 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11760 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11761 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11762 corresponding range type from debug information; fall back to using it
11763 if symbol lookup fails. If a new type must be created, allocate it
11764 like ORIG_TYPE was. The bounds information, in general, is encoded
11765 in NAME, the base type given in the named range type. */
14f9c5c9 11766
d2e4a39e 11767static struct type *
28c85d6c 11768to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11769{
0d5cff50 11770 const char *name;
14f9c5c9 11771 struct type *base_type;
108d56a4 11772 const char *subtype_info;
14f9c5c9 11773
28c85d6c
JB
11774 gdb_assert (raw_type != NULL);
11775 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11776
1ce677a4 11777 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11778 base_type = TYPE_TARGET_TYPE (raw_type);
11779 else
11780 base_type = raw_type;
11781
28c85d6c 11782 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11783 subtype_info = strstr (name, "___XD");
11784 if (subtype_info == NULL)
690cc4eb 11785 {
43bbcdc2
PH
11786 LONGEST L = ada_discrete_type_low_bound (raw_type);
11787 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11788
690cc4eb
PH
11789 if (L < INT_MIN || U > INT_MAX)
11790 return raw_type;
11791 else
0c9c3474
SA
11792 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11793 L, U);
690cc4eb 11794 }
14f9c5c9
AS
11795 else
11796 {
11797 static char *name_buf = NULL;
11798 static size_t name_len = 0;
11799 int prefix_len = subtype_info - name;
11800 LONGEST L, U;
11801 struct type *type;
108d56a4 11802 const char *bounds_str;
14f9c5c9
AS
11803 int n;
11804
11805 GROW_VECT (name_buf, name_len, prefix_len + 5);
11806 strncpy (name_buf, name, prefix_len);
11807 name_buf[prefix_len] = '\0';
11808
11809 subtype_info += 5;
11810 bounds_str = strchr (subtype_info, '_');
11811 n = 1;
11812
d2e4a39e 11813 if (*subtype_info == 'L')
4c4b4cd2
PH
11814 {
11815 if (!ada_scan_number (bounds_str, n, &L, &n)
11816 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11817 return raw_type;
11818 if (bounds_str[n] == '_')
11819 n += 2;
0963b4bd 11820 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11821 n += 1;
11822 subtype_info += 1;
11823 }
d2e4a39e 11824 else
4c4b4cd2 11825 {
4c4b4cd2 11826 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11827 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11828 {
323e0a4a 11829 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11830 L = 1;
11831 }
11832 }
14f9c5c9 11833
d2e4a39e 11834 if (*subtype_info == 'U')
4c4b4cd2
PH
11835 {
11836 if (!ada_scan_number (bounds_str, n, &U, &n)
11837 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11838 return raw_type;
11839 }
d2e4a39e 11840 else
4c4b4cd2 11841 {
4c4b4cd2 11842 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11843 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11844 {
323e0a4a 11845 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11846 U = L;
11847 }
11848 }
14f9c5c9 11849
0c9c3474
SA
11850 type = create_static_range_type (alloc_type_copy (raw_type),
11851 base_type, L, U);
f5a91472
JB
11852 /* create_static_range_type alters the resulting type's length
11853 to match the size of the base_type, which is not what we want.
11854 Set it back to the original range type's length. */
11855 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11856 TYPE_NAME (type) = name;
14f9c5c9
AS
11857 return type;
11858 }
11859}
11860
4c4b4cd2
PH
11861/* True iff NAME is the name of a range type. */
11862
14f9c5c9 11863int
d2e4a39e 11864ada_is_range_type_name (const char *name)
14f9c5c9
AS
11865{
11866 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11867}
14f9c5c9 11868\f
d2e4a39e 11869
4c4b4cd2
PH
11870 /* Modular types */
11871
11872/* True iff TYPE is an Ada modular type. */
14f9c5c9 11873
14f9c5c9 11874int
d2e4a39e 11875ada_is_modular_type (struct type *type)
14f9c5c9 11876{
18af8284 11877 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11878
11879 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11880 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11881 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11882}
11883
4c4b4cd2
PH
11884/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11885
61ee279c 11886ULONGEST
0056e4d5 11887ada_modulus (struct type *type)
14f9c5c9 11888{
43bbcdc2 11889 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11890}
d2e4a39e 11891\f
f7f9143b
JB
11892
11893/* Ada exception catchpoint support:
11894 ---------------------------------
11895
11896 We support 3 kinds of exception catchpoints:
11897 . catchpoints on Ada exceptions
11898 . catchpoints on unhandled Ada exceptions
11899 . catchpoints on failed assertions
11900
11901 Exceptions raised during failed assertions, or unhandled exceptions
11902 could perfectly be caught with the general catchpoint on Ada exceptions.
11903 However, we can easily differentiate these two special cases, and having
11904 the option to distinguish these two cases from the rest can be useful
11905 to zero-in on certain situations.
11906
11907 Exception catchpoints are a specialized form of breakpoint,
11908 since they rely on inserting breakpoints inside known routines
11909 of the GNAT runtime. The implementation therefore uses a standard
11910 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11911 of breakpoint_ops.
11912
0259addd
JB
11913 Support in the runtime for exception catchpoints have been changed
11914 a few times already, and these changes affect the implementation
11915 of these catchpoints. In order to be able to support several
11916 variants of the runtime, we use a sniffer that will determine
28010a5d 11917 the runtime variant used by the program being debugged. */
f7f9143b 11918
82eacd52
JB
11919/* Ada's standard exceptions.
11920
11921 The Ada 83 standard also defined Numeric_Error. But there so many
11922 situations where it was unclear from the Ada 83 Reference Manual
11923 (RM) whether Constraint_Error or Numeric_Error should be raised,
11924 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11925 Interpretation saying that anytime the RM says that Numeric_Error
11926 should be raised, the implementation may raise Constraint_Error.
11927 Ada 95 went one step further and pretty much removed Numeric_Error
11928 from the list of standard exceptions (it made it a renaming of
11929 Constraint_Error, to help preserve compatibility when compiling
11930 an Ada83 compiler). As such, we do not include Numeric_Error from
11931 this list of standard exceptions. */
3d0b0fa3 11932
a121b7c1 11933static const char *standard_exc[] = {
3d0b0fa3
JB
11934 "constraint_error",
11935 "program_error",
11936 "storage_error",
11937 "tasking_error"
11938};
11939
0259addd
JB
11940typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11941
11942/* A structure that describes how to support exception catchpoints
11943 for a given executable. */
11944
11945struct exception_support_info
11946{
11947 /* The name of the symbol to break on in order to insert
11948 a catchpoint on exceptions. */
11949 const char *catch_exception_sym;
11950
11951 /* The name of the symbol to break on in order to insert
11952 a catchpoint on unhandled exceptions. */
11953 const char *catch_exception_unhandled_sym;
11954
11955 /* The name of the symbol to break on in order to insert
11956 a catchpoint on failed assertions. */
11957 const char *catch_assert_sym;
11958
9f757bf7
XR
11959 /* The name of the symbol to break on in order to insert
11960 a catchpoint on exception handling. */
11961 const char *catch_handlers_sym;
11962
0259addd
JB
11963 /* Assuming that the inferior just triggered an unhandled exception
11964 catchpoint, this function is responsible for returning the address
11965 in inferior memory where the name of that exception is stored.
11966 Return zero if the address could not be computed. */
11967 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11968};
11969
11970static CORE_ADDR ada_unhandled_exception_name_addr (void);
11971static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11972
11973/* The following exception support info structure describes how to
11974 implement exception catchpoints with the latest version of the
11975 Ada runtime (as of 2007-03-06). */
11976
11977static const struct exception_support_info default_exception_support_info =
11978{
11979 "__gnat_debug_raise_exception", /* catch_exception_sym */
11980 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11981 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 11982 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
11983 ada_unhandled_exception_name_addr
11984};
11985
11986/* The following exception support info structure describes how to
11987 implement exception catchpoints with a slightly older version
11988 of the Ada runtime. */
11989
11990static const struct exception_support_info exception_support_info_fallback =
11991{
11992 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11993 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11994 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 11995 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
11996 ada_unhandled_exception_name_addr_from_raise
11997};
11998
f17011e0
JB
11999/* Return nonzero if we can detect the exception support routines
12000 described in EINFO.
12001
12002 This function errors out if an abnormal situation is detected
12003 (for instance, if we find the exception support routines, but
12004 that support is found to be incomplete). */
12005
12006static int
12007ada_has_this_exception_support (const struct exception_support_info *einfo)
12008{
12009 struct symbol *sym;
12010
12011 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12012 that should be compiled with debugging information. As a result, we
12013 expect to find that symbol in the symtabs. */
12014
12015 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12016 if (sym == NULL)
a6af7abe
JB
12017 {
12018 /* Perhaps we did not find our symbol because the Ada runtime was
12019 compiled without debugging info, or simply stripped of it.
12020 It happens on some GNU/Linux distributions for instance, where
12021 users have to install a separate debug package in order to get
12022 the runtime's debugging info. In that situation, let the user
12023 know why we cannot insert an Ada exception catchpoint.
12024
12025 Note: Just for the purpose of inserting our Ada exception
12026 catchpoint, we could rely purely on the associated minimal symbol.
12027 But we would be operating in degraded mode anyway, since we are
12028 still lacking the debugging info needed later on to extract
12029 the name of the exception being raised (this name is printed in
12030 the catchpoint message, and is also used when trying to catch
12031 a specific exception). We do not handle this case for now. */
3b7344d5 12032 struct bound_minimal_symbol msym
1c8e84b0
JB
12033 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12034
3b7344d5 12035 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
12036 error (_("Your Ada runtime appears to be missing some debugging "
12037 "information.\nCannot insert Ada exception catchpoint "
12038 "in this configuration."));
12039
12040 return 0;
12041 }
f17011e0
JB
12042
12043 /* Make sure that the symbol we found corresponds to a function. */
12044
12045 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12046 error (_("Symbol \"%s\" is not a function (class = %d)"),
12047 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12048
12049 return 1;
12050}
12051
0259addd
JB
12052/* Inspect the Ada runtime and determine which exception info structure
12053 should be used to provide support for exception catchpoints.
12054
3eecfa55
JB
12055 This function will always set the per-inferior exception_info,
12056 or raise an error. */
0259addd
JB
12057
12058static void
12059ada_exception_support_info_sniffer (void)
12060{
3eecfa55 12061 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
12062
12063 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 12064 if (data->exception_info != NULL)
0259addd
JB
12065 return;
12066
12067 /* Check the latest (default) exception support info. */
f17011e0 12068 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 12069 {
3eecfa55 12070 data->exception_info = &default_exception_support_info;
0259addd
JB
12071 return;
12072 }
12073
12074 /* Try our fallback exception suport info. */
f17011e0 12075 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 12076 {
3eecfa55 12077 data->exception_info = &exception_support_info_fallback;
0259addd
JB
12078 return;
12079 }
12080
12081 /* Sometimes, it is normal for us to not be able to find the routine
12082 we are looking for. This happens when the program is linked with
12083 the shared version of the GNAT runtime, and the program has not been
12084 started yet. Inform the user of these two possible causes if
12085 applicable. */
12086
ccefe4c4 12087 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
12088 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12089
12090 /* If the symbol does not exist, then check that the program is
12091 already started, to make sure that shared libraries have been
12092 loaded. If it is not started, this may mean that the symbol is
12093 in a shared library. */
12094
e99b03dc 12095 if (inferior_ptid.pid () == 0)
0259addd
JB
12096 error (_("Unable to insert catchpoint. Try to start the program first."));
12097
12098 /* At this point, we know that we are debugging an Ada program and
12099 that the inferior has been started, but we still are not able to
0963b4bd 12100 find the run-time symbols. That can mean that we are in
0259addd
JB
12101 configurable run time mode, or that a-except as been optimized
12102 out by the linker... In any case, at this point it is not worth
12103 supporting this feature. */
12104
7dda8cff 12105 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12106}
12107
f7f9143b
JB
12108/* True iff FRAME is very likely to be that of a function that is
12109 part of the runtime system. This is all very heuristic, but is
12110 intended to be used as advice as to what frames are uninteresting
12111 to most users. */
12112
12113static int
12114is_known_support_routine (struct frame_info *frame)
12115{
692465f1 12116 enum language func_lang;
f7f9143b 12117 int i;
f35a17b5 12118 const char *fullname;
f7f9143b 12119
4ed6b5be
JB
12120 /* If this code does not have any debugging information (no symtab),
12121 This cannot be any user code. */
f7f9143b 12122
51abb421 12123 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12124 if (sal.symtab == NULL)
12125 return 1;
12126
4ed6b5be
JB
12127 /* If there is a symtab, but the associated source file cannot be
12128 located, then assume this is not user code: Selecting a frame
12129 for which we cannot display the code would not be very helpful
12130 for the user. This should also take care of case such as VxWorks
12131 where the kernel has some debugging info provided for a few units. */
f7f9143b 12132
f35a17b5
JK
12133 fullname = symtab_to_fullname (sal.symtab);
12134 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12135 return 1;
12136
4ed6b5be
JB
12137 /* Check the unit filename againt the Ada runtime file naming.
12138 We also check the name of the objfile against the name of some
12139 known system libraries that sometimes come with debugging info
12140 too. */
12141
f7f9143b
JB
12142 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12143 {
12144 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12145 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12146 return 1;
eb822aa6
DE
12147 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12148 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12149 return 1;
f7f9143b
JB
12150 }
12151
4ed6b5be 12152 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12153
c6dc63a1
TT
12154 gdb::unique_xmalloc_ptr<char> func_name
12155 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12156 if (func_name == NULL)
12157 return 1;
12158
12159 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12160 {
12161 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12162 if (re_exec (func_name.get ()))
12163 return 1;
f7f9143b
JB
12164 }
12165
12166 return 0;
12167}
12168
12169/* Find the first frame that contains debugging information and that is not
12170 part of the Ada run-time, starting from FI and moving upward. */
12171
0ef643c8 12172void
f7f9143b
JB
12173ada_find_printable_frame (struct frame_info *fi)
12174{
12175 for (; fi != NULL; fi = get_prev_frame (fi))
12176 {
12177 if (!is_known_support_routine (fi))
12178 {
12179 select_frame (fi);
12180 break;
12181 }
12182 }
12183
12184}
12185
12186/* Assuming that the inferior just triggered an unhandled exception
12187 catchpoint, return the address in inferior memory where the name
12188 of the exception is stored.
12189
12190 Return zero if the address could not be computed. */
12191
12192static CORE_ADDR
12193ada_unhandled_exception_name_addr (void)
0259addd
JB
12194{
12195 return parse_and_eval_address ("e.full_name");
12196}
12197
12198/* Same as ada_unhandled_exception_name_addr, except that this function
12199 should be used when the inferior uses an older version of the runtime,
12200 where the exception name needs to be extracted from a specific frame
12201 several frames up in the callstack. */
12202
12203static CORE_ADDR
12204ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12205{
12206 int frame_level;
12207 struct frame_info *fi;
3eecfa55 12208 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12209
12210 /* To determine the name of this exception, we need to select
12211 the frame corresponding to RAISE_SYM_NAME. This frame is
12212 at least 3 levels up, so we simply skip the first 3 frames
12213 without checking the name of their associated function. */
12214 fi = get_current_frame ();
12215 for (frame_level = 0; frame_level < 3; frame_level += 1)
12216 if (fi != NULL)
12217 fi = get_prev_frame (fi);
12218
12219 while (fi != NULL)
12220 {
692465f1
JB
12221 enum language func_lang;
12222
c6dc63a1
TT
12223 gdb::unique_xmalloc_ptr<char> func_name
12224 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12225 if (func_name != NULL)
12226 {
c6dc63a1 12227 if (strcmp (func_name.get (),
55b87a52
KS
12228 data->exception_info->catch_exception_sym) == 0)
12229 break; /* We found the frame we were looking for... */
55b87a52 12230 }
fb44b1a7 12231 fi = get_prev_frame (fi);
f7f9143b
JB
12232 }
12233
12234 if (fi == NULL)
12235 return 0;
12236
12237 select_frame (fi);
12238 return parse_and_eval_address ("id.full_name");
12239}
12240
12241/* Assuming the inferior just triggered an Ada exception catchpoint
12242 (of any type), return the address in inferior memory where the name
12243 of the exception is stored, if applicable.
12244
45db7c09
PA
12245 Assumes the selected frame is the current frame.
12246
f7f9143b
JB
12247 Return zero if the address could not be computed, or if not relevant. */
12248
12249static CORE_ADDR
761269c8 12250ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12251 struct breakpoint *b)
12252{
3eecfa55
JB
12253 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12254
f7f9143b
JB
12255 switch (ex)
12256 {
761269c8 12257 case ada_catch_exception:
f7f9143b
JB
12258 return (parse_and_eval_address ("e.full_name"));
12259 break;
12260
761269c8 12261 case ada_catch_exception_unhandled:
3eecfa55 12262 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12263 break;
9f757bf7
XR
12264
12265 case ada_catch_handlers:
12266 return 0; /* The runtimes does not provide access to the exception
12267 name. */
12268 break;
12269
761269c8 12270 case ada_catch_assert:
f7f9143b
JB
12271 return 0; /* Exception name is not relevant in this case. */
12272 break;
12273
12274 default:
12275 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12276 break;
12277 }
12278
12279 return 0; /* Should never be reached. */
12280}
12281
e547c119
JB
12282/* Assuming the inferior is stopped at an exception catchpoint,
12283 return the message which was associated to the exception, if
12284 available. Return NULL if the message could not be retrieved.
12285
e547c119
JB
12286 Note: The exception message can be associated to an exception
12287 either through the use of the Raise_Exception function, or
12288 more simply (Ada 2005 and later), via:
12289
12290 raise Exception_Name with "exception message";
12291
12292 */
12293
6f46ac85 12294static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12295ada_exception_message_1 (void)
12296{
12297 struct value *e_msg_val;
e547c119 12298 int e_msg_len;
e547c119
JB
12299
12300 /* For runtimes that support this feature, the exception message
12301 is passed as an unbounded string argument called "message". */
12302 e_msg_val = parse_and_eval ("message");
12303 if (e_msg_val == NULL)
12304 return NULL; /* Exception message not supported. */
12305
12306 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12307 gdb_assert (e_msg_val != NULL);
12308 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12309
12310 /* If the message string is empty, then treat it as if there was
12311 no exception message. */
12312 if (e_msg_len <= 0)
12313 return NULL;
12314
6f46ac85
TT
12315 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12316 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12317 e_msg.get ()[e_msg_len] = '\0';
e547c119 12318
e547c119
JB
12319 return e_msg;
12320}
12321
12322/* Same as ada_exception_message_1, except that all exceptions are
12323 contained here (returning NULL instead). */
12324
6f46ac85 12325static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12326ada_exception_message (void)
12327{
6f46ac85 12328 gdb::unique_xmalloc_ptr<char> e_msg;
e547c119
JB
12329
12330 TRY
12331 {
12332 e_msg = ada_exception_message_1 ();
12333 }
12334 CATCH (e, RETURN_MASK_ERROR)
12335 {
6f46ac85 12336 e_msg.reset (nullptr);
e547c119
JB
12337 }
12338 END_CATCH
12339
12340 return e_msg;
12341}
12342
f7f9143b
JB
12343/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12344 any error that ada_exception_name_addr_1 might cause to be thrown.
12345 When an error is intercepted, a warning with the error message is printed,
12346 and zero is returned. */
12347
12348static CORE_ADDR
761269c8 12349ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12350 struct breakpoint *b)
12351{
f7f9143b
JB
12352 CORE_ADDR result = 0;
12353
492d29ea 12354 TRY
f7f9143b
JB
12355 {
12356 result = ada_exception_name_addr_1 (ex, b);
12357 }
12358
492d29ea 12359 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12360 {
12361 warning (_("failed to get exception name: %s"), e.message);
12362 return 0;
12363 }
492d29ea 12364 END_CATCH
f7f9143b
JB
12365
12366 return result;
12367}
12368
cb7de75e 12369static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12370 (const char *excep_string,
12371 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12372
12373/* Ada catchpoints.
12374
12375 In the case of catchpoints on Ada exceptions, the catchpoint will
12376 stop the target on every exception the program throws. When a user
12377 specifies the name of a specific exception, we translate this
12378 request into a condition expression (in text form), and then parse
12379 it into an expression stored in each of the catchpoint's locations.
12380 We then use this condition to check whether the exception that was
12381 raised is the one the user is interested in. If not, then the
12382 target is resumed again. We store the name of the requested
12383 exception, in order to be able to re-set the condition expression
12384 when symbols change. */
12385
12386/* An instance of this type is used to represent an Ada catchpoint
5625a286 12387 breakpoint location. */
28010a5d 12388
5625a286 12389class ada_catchpoint_location : public bp_location
28010a5d 12390{
5625a286
PA
12391public:
12392 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12393 : bp_location (ops, owner)
12394 {}
28010a5d
PA
12395
12396 /* The condition that checks whether the exception that was raised
12397 is the specific exception the user specified on catchpoint
12398 creation. */
4d01a485 12399 expression_up excep_cond_expr;
28010a5d
PA
12400};
12401
12402/* Implement the DTOR method in the bp_location_ops structure for all
12403 Ada exception catchpoint kinds. */
12404
12405static void
12406ada_catchpoint_location_dtor (struct bp_location *bl)
12407{
12408 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12409
4d01a485 12410 al->excep_cond_expr.reset ();
28010a5d
PA
12411}
12412
12413/* The vtable to be used in Ada catchpoint locations. */
12414
12415static const struct bp_location_ops ada_catchpoint_location_ops =
12416{
12417 ada_catchpoint_location_dtor
12418};
12419
c1fc2657 12420/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12421
c1fc2657 12422struct ada_catchpoint : public breakpoint
28010a5d 12423{
28010a5d 12424 /* The name of the specific exception the user specified. */
bc18fbb5 12425 std::string excep_string;
28010a5d
PA
12426};
12427
12428/* Parse the exception condition string in the context of each of the
12429 catchpoint's locations, and store them for later evaluation. */
12430
12431static void
9f757bf7
XR
12432create_excep_cond_exprs (struct ada_catchpoint *c,
12433 enum ada_exception_catchpoint_kind ex)
28010a5d 12434{
28010a5d 12435 struct bp_location *bl;
28010a5d
PA
12436
12437 /* Nothing to do if there's no specific exception to catch. */
bc18fbb5 12438 if (c->excep_string.empty ())
28010a5d
PA
12439 return;
12440
12441 /* Same if there are no locations... */
c1fc2657 12442 if (c->loc == NULL)
28010a5d
PA
12443 return;
12444
12445 /* Compute the condition expression in text form, from the specific
12446 expection we want to catch. */
cb7de75e 12447 std::string cond_string
bc18fbb5 12448 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
28010a5d
PA
12449
12450 /* Iterate over all the catchpoint's locations, and parse an
12451 expression for each. */
c1fc2657 12452 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12453 {
12454 struct ada_catchpoint_location *ada_loc
12455 = (struct ada_catchpoint_location *) bl;
4d01a485 12456 expression_up exp;
28010a5d
PA
12457
12458 if (!bl->shlib_disabled)
12459 {
bbc13ae3 12460 const char *s;
28010a5d 12461
cb7de75e 12462 s = cond_string.c_str ();
492d29ea 12463 TRY
28010a5d 12464 {
036e657b
JB
12465 exp = parse_exp_1 (&s, bl->address,
12466 block_for_pc (bl->address),
12467 0);
28010a5d 12468 }
492d29ea 12469 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12470 {
12471 warning (_("failed to reevaluate internal exception condition "
12472 "for catchpoint %d: %s"),
c1fc2657 12473 c->number, e.message);
849f2b52 12474 }
492d29ea 12475 END_CATCH
28010a5d
PA
12476 }
12477
b22e99fd 12478 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12479 }
28010a5d
PA
12480}
12481
28010a5d
PA
12482/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12483 structure for all exception catchpoint kinds. */
12484
12485static struct bp_location *
761269c8 12486allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12487 struct breakpoint *self)
12488{
5625a286 12489 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12490}
12491
12492/* Implement the RE_SET method in the breakpoint_ops structure for all
12493 exception catchpoint kinds. */
12494
12495static void
761269c8 12496re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12497{
12498 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12499
12500 /* Call the base class's method. This updates the catchpoint's
12501 locations. */
2060206e 12502 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12503
12504 /* Reparse the exception conditional expressions. One for each
12505 location. */
9f757bf7 12506 create_excep_cond_exprs (c, ex);
28010a5d
PA
12507}
12508
12509/* Returns true if we should stop for this breakpoint hit. If the
12510 user specified a specific exception, we only want to cause a stop
12511 if the program thrown that exception. */
12512
12513static int
12514should_stop_exception (const struct bp_location *bl)
12515{
12516 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12517 const struct ada_catchpoint_location *ada_loc
12518 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12519 int stop;
12520
12521 /* With no specific exception, should always stop. */
bc18fbb5 12522 if (c->excep_string.empty ())
28010a5d
PA
12523 return 1;
12524
12525 if (ada_loc->excep_cond_expr == NULL)
12526 {
12527 /* We will have a NULL expression if back when we were creating
12528 the expressions, this location's had failed to parse. */
12529 return 1;
12530 }
12531
12532 stop = 1;
492d29ea 12533 TRY
28010a5d
PA
12534 {
12535 struct value *mark;
12536
12537 mark = value_mark ();
4d01a485 12538 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12539 value_free_to_mark (mark);
12540 }
492d29ea
PA
12541 CATCH (ex, RETURN_MASK_ALL)
12542 {
12543 exception_fprintf (gdb_stderr, ex,
12544 _("Error in testing exception condition:\n"));
12545 }
12546 END_CATCH
12547
28010a5d
PA
12548 return stop;
12549}
12550
12551/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12552 for all exception catchpoint kinds. */
12553
12554static void
761269c8 12555check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12556{
12557 bs->stop = should_stop_exception (bs->bp_location_at);
12558}
12559
f7f9143b
JB
12560/* Implement the PRINT_IT method in the breakpoint_ops structure
12561 for all exception catchpoint kinds. */
12562
12563static enum print_stop_action
761269c8 12564print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12565{
79a45e25 12566 struct ui_out *uiout = current_uiout;
348d480f
PA
12567 struct breakpoint *b = bs->breakpoint_at;
12568
956a9fb9 12569 annotate_catchpoint (b->number);
f7f9143b 12570
112e8700 12571 if (uiout->is_mi_like_p ())
f7f9143b 12572 {
112e8700 12573 uiout->field_string ("reason",
956a9fb9 12574 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12575 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12576 }
12577
112e8700
SM
12578 uiout->text (b->disposition == disp_del
12579 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12580 uiout->field_int ("bkptno", b->number);
12581 uiout->text (", ");
f7f9143b 12582
45db7c09
PA
12583 /* ada_exception_name_addr relies on the selected frame being the
12584 current frame. Need to do this here because this function may be
12585 called more than once when printing a stop, and below, we'll
12586 select the first frame past the Ada run-time (see
12587 ada_find_printable_frame). */
12588 select_frame (get_current_frame ());
12589
f7f9143b
JB
12590 switch (ex)
12591 {
761269c8
JB
12592 case ada_catch_exception:
12593 case ada_catch_exception_unhandled:
9f757bf7 12594 case ada_catch_handlers:
956a9fb9
JB
12595 {
12596 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12597 char exception_name[256];
12598
12599 if (addr != 0)
12600 {
c714b426
PA
12601 read_memory (addr, (gdb_byte *) exception_name,
12602 sizeof (exception_name) - 1);
956a9fb9
JB
12603 exception_name [sizeof (exception_name) - 1] = '\0';
12604 }
12605 else
12606 {
12607 /* For some reason, we were unable to read the exception
12608 name. This could happen if the Runtime was compiled
12609 without debugging info, for instance. In that case,
12610 just replace the exception name by the generic string
12611 "exception" - it will read as "an exception" in the
12612 notification we are about to print. */
967cff16 12613 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12614 }
12615 /* In the case of unhandled exception breakpoints, we print
12616 the exception name as "unhandled EXCEPTION_NAME", to make
12617 it clearer to the user which kind of catchpoint just got
12618 hit. We used ui_out_text to make sure that this extra
12619 info does not pollute the exception name in the MI case. */
761269c8 12620 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12621 uiout->text ("unhandled ");
12622 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12623 }
12624 break;
761269c8 12625 case ada_catch_assert:
956a9fb9
JB
12626 /* In this case, the name of the exception is not really
12627 important. Just print "failed assertion" to make it clearer
12628 that his program just hit an assertion-failure catchpoint.
12629 We used ui_out_text because this info does not belong in
12630 the MI output. */
112e8700 12631 uiout->text ("failed assertion");
956a9fb9 12632 break;
f7f9143b 12633 }
e547c119 12634
6f46ac85 12635 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
e547c119
JB
12636 if (exception_message != NULL)
12637 {
e547c119 12638 uiout->text (" (");
6f46ac85 12639 uiout->field_string ("exception-message", exception_message.get ());
e547c119 12640 uiout->text (")");
e547c119
JB
12641 }
12642
112e8700 12643 uiout->text (" at ");
956a9fb9 12644 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12645
12646 return PRINT_SRC_AND_LOC;
12647}
12648
12649/* Implement the PRINT_ONE method in the breakpoint_ops structure
12650 for all exception catchpoint kinds. */
12651
12652static void
761269c8 12653print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12654 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12655{
79a45e25 12656 struct ui_out *uiout = current_uiout;
28010a5d 12657 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12658 struct value_print_options opts;
12659
12660 get_user_print_options (&opts);
12661 if (opts.addressprint)
f7f9143b
JB
12662 {
12663 annotate_field (4);
112e8700 12664 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12665 }
12666
12667 annotate_field (5);
a6d9a66e 12668 *last_loc = b->loc;
f7f9143b
JB
12669 switch (ex)
12670 {
761269c8 12671 case ada_catch_exception:
bc18fbb5 12672 if (!c->excep_string.empty ())
f7f9143b 12673 {
bc18fbb5
TT
12674 std::string msg = string_printf (_("`%s' Ada exception"),
12675 c->excep_string.c_str ());
28010a5d 12676
112e8700 12677 uiout->field_string ("what", msg);
f7f9143b
JB
12678 }
12679 else
112e8700 12680 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12681
12682 break;
12683
761269c8 12684 case ada_catch_exception_unhandled:
112e8700 12685 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12686 break;
12687
9f757bf7 12688 case ada_catch_handlers:
bc18fbb5 12689 if (!c->excep_string.empty ())
9f757bf7
XR
12690 {
12691 uiout->field_fmt ("what",
12692 _("`%s' Ada exception handlers"),
bc18fbb5 12693 c->excep_string.c_str ());
9f757bf7
XR
12694 }
12695 else
12696 uiout->field_string ("what", "all Ada exceptions handlers");
12697 break;
12698
761269c8 12699 case ada_catch_assert:
112e8700 12700 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12701 break;
12702
12703 default:
12704 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12705 break;
12706 }
12707}
12708
12709/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12710 for all exception catchpoint kinds. */
12711
12712static void
761269c8 12713print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12714 struct breakpoint *b)
12715{
28010a5d 12716 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12717 struct ui_out *uiout = current_uiout;
28010a5d 12718
112e8700 12719 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12720 : _("Catchpoint "));
112e8700
SM
12721 uiout->field_int ("bkptno", b->number);
12722 uiout->text (": ");
00eb2c4a 12723
f7f9143b
JB
12724 switch (ex)
12725 {
761269c8 12726 case ada_catch_exception:
bc18fbb5 12727 if (!c->excep_string.empty ())
00eb2c4a 12728 {
862d101a 12729 std::string info = string_printf (_("`%s' Ada exception"),
bc18fbb5 12730 c->excep_string.c_str ());
862d101a 12731 uiout->text (info.c_str ());
00eb2c4a 12732 }
f7f9143b 12733 else
112e8700 12734 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12735 break;
12736
761269c8 12737 case ada_catch_exception_unhandled:
112e8700 12738 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12739 break;
9f757bf7
XR
12740
12741 case ada_catch_handlers:
bc18fbb5 12742 if (!c->excep_string.empty ())
9f757bf7
XR
12743 {
12744 std::string info
12745 = string_printf (_("`%s' Ada exception handlers"),
bc18fbb5 12746 c->excep_string.c_str ());
9f757bf7
XR
12747 uiout->text (info.c_str ());
12748 }
12749 else
12750 uiout->text (_("all Ada exceptions handlers"));
12751 break;
12752
761269c8 12753 case ada_catch_assert:
112e8700 12754 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12755 break;
12756
12757 default:
12758 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12759 break;
12760 }
12761}
12762
6149aea9
PA
12763/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12764 for all exception catchpoint kinds. */
12765
12766static void
761269c8 12767print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12768 struct breakpoint *b, struct ui_file *fp)
12769{
28010a5d
PA
12770 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12771
6149aea9
PA
12772 switch (ex)
12773 {
761269c8 12774 case ada_catch_exception:
6149aea9 12775 fprintf_filtered (fp, "catch exception");
bc18fbb5
TT
12776 if (!c->excep_string.empty ())
12777 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
6149aea9
PA
12778 break;
12779
761269c8 12780 case ada_catch_exception_unhandled:
78076abc 12781 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12782 break;
12783
9f757bf7
XR
12784 case ada_catch_handlers:
12785 fprintf_filtered (fp, "catch handlers");
12786 break;
12787
761269c8 12788 case ada_catch_assert:
6149aea9
PA
12789 fprintf_filtered (fp, "catch assert");
12790 break;
12791
12792 default:
12793 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12794 }
d9b3f62e 12795 print_recreate_thread (b, fp);
6149aea9
PA
12796}
12797
f7f9143b
JB
12798/* Virtual table for "catch exception" breakpoints. */
12799
28010a5d
PA
12800static struct bp_location *
12801allocate_location_catch_exception (struct breakpoint *self)
12802{
761269c8 12803 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12804}
12805
12806static void
12807re_set_catch_exception (struct breakpoint *b)
12808{
761269c8 12809 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12810}
12811
12812static void
12813check_status_catch_exception (bpstat bs)
12814{
761269c8 12815 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12816}
12817
f7f9143b 12818static enum print_stop_action
348d480f 12819print_it_catch_exception (bpstat bs)
f7f9143b 12820{
761269c8 12821 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12822}
12823
12824static void
a6d9a66e 12825print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12826{
761269c8 12827 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12828}
12829
12830static void
12831print_mention_catch_exception (struct breakpoint *b)
12832{
761269c8 12833 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12834}
12835
6149aea9
PA
12836static void
12837print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12838{
761269c8 12839 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12840}
12841
2060206e 12842static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12843
12844/* Virtual table for "catch exception unhandled" breakpoints. */
12845
28010a5d
PA
12846static struct bp_location *
12847allocate_location_catch_exception_unhandled (struct breakpoint *self)
12848{
761269c8 12849 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12850}
12851
12852static void
12853re_set_catch_exception_unhandled (struct breakpoint *b)
12854{
761269c8 12855 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12856}
12857
12858static void
12859check_status_catch_exception_unhandled (bpstat bs)
12860{
761269c8 12861 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12862}
12863
f7f9143b 12864static enum print_stop_action
348d480f 12865print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12866{
761269c8 12867 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12868}
12869
12870static void
a6d9a66e
UW
12871print_one_catch_exception_unhandled (struct breakpoint *b,
12872 struct bp_location **last_loc)
f7f9143b 12873{
761269c8 12874 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12875}
12876
12877static void
12878print_mention_catch_exception_unhandled (struct breakpoint *b)
12879{
761269c8 12880 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12881}
12882
6149aea9
PA
12883static void
12884print_recreate_catch_exception_unhandled (struct breakpoint *b,
12885 struct ui_file *fp)
12886{
761269c8 12887 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12888}
12889
2060206e 12890static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12891
12892/* Virtual table for "catch assert" breakpoints. */
12893
28010a5d
PA
12894static struct bp_location *
12895allocate_location_catch_assert (struct breakpoint *self)
12896{
761269c8 12897 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12898}
12899
12900static void
12901re_set_catch_assert (struct breakpoint *b)
12902{
761269c8 12903 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12904}
12905
12906static void
12907check_status_catch_assert (bpstat bs)
12908{
761269c8 12909 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12910}
12911
f7f9143b 12912static enum print_stop_action
348d480f 12913print_it_catch_assert (bpstat bs)
f7f9143b 12914{
761269c8 12915 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12916}
12917
12918static void
a6d9a66e 12919print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12920{
761269c8 12921 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12922}
12923
12924static void
12925print_mention_catch_assert (struct breakpoint *b)
12926{
761269c8 12927 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12928}
12929
6149aea9
PA
12930static void
12931print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12932{
761269c8 12933 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12934}
12935
2060206e 12936static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12937
9f757bf7
XR
12938/* Virtual table for "catch handlers" breakpoints. */
12939
12940static struct bp_location *
12941allocate_location_catch_handlers (struct breakpoint *self)
12942{
12943 return allocate_location_exception (ada_catch_handlers, self);
12944}
12945
12946static void
12947re_set_catch_handlers (struct breakpoint *b)
12948{
12949 re_set_exception (ada_catch_handlers, b);
12950}
12951
12952static void
12953check_status_catch_handlers (bpstat bs)
12954{
12955 check_status_exception (ada_catch_handlers, bs);
12956}
12957
12958static enum print_stop_action
12959print_it_catch_handlers (bpstat bs)
12960{
12961 return print_it_exception (ada_catch_handlers, bs);
12962}
12963
12964static void
12965print_one_catch_handlers (struct breakpoint *b,
12966 struct bp_location **last_loc)
12967{
12968 print_one_exception (ada_catch_handlers, b, last_loc);
12969}
12970
12971static void
12972print_mention_catch_handlers (struct breakpoint *b)
12973{
12974 print_mention_exception (ada_catch_handlers, b);
12975}
12976
12977static void
12978print_recreate_catch_handlers (struct breakpoint *b,
12979 struct ui_file *fp)
12980{
12981 print_recreate_exception (ada_catch_handlers, b, fp);
12982}
12983
12984static struct breakpoint_ops catch_handlers_breakpoint_ops;
12985
f7f9143b
JB
12986/* Split the arguments specified in a "catch exception" command.
12987 Set EX to the appropriate catchpoint type.
28010a5d 12988 Set EXCEP_STRING to the name of the specific exception if
5845583d 12989 specified by the user.
9f757bf7
XR
12990 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12991 "catch handlers" command. False otherwise.
5845583d
JB
12992 If a condition is found at the end of the arguments, the condition
12993 expression is stored in COND_STRING (memory must be deallocated
12994 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12995
12996static void
a121b7c1 12997catch_ada_exception_command_split (const char *args,
9f757bf7 12998 bool is_catch_handlers_cmd,
761269c8 12999 enum ada_exception_catchpoint_kind *ex,
bc18fbb5
TT
13000 std::string *excep_string,
13001 std::string *cond_string)
f7f9143b 13002{
bc18fbb5 13003 std::string exception_name;
f7f9143b 13004
bc18fbb5
TT
13005 exception_name = extract_arg (&args);
13006 if (exception_name == "if")
5845583d
JB
13007 {
13008 /* This is not an exception name; this is the start of a condition
13009 expression for a catchpoint on all exceptions. So, "un-get"
13010 this token, and set exception_name to NULL. */
bc18fbb5 13011 exception_name.clear ();
5845583d
JB
13012 args -= 2;
13013 }
f7f9143b 13014
5845583d 13015 /* Check to see if we have a condition. */
f7f9143b 13016
f1735a53 13017 args = skip_spaces (args);
61012eef 13018 if (startswith (args, "if")
5845583d
JB
13019 && (isspace (args[2]) || args[2] == '\0'))
13020 {
13021 args += 2;
f1735a53 13022 args = skip_spaces (args);
5845583d
JB
13023
13024 if (args[0] == '\0')
13025 error (_("Condition missing after `if' keyword"));
bc18fbb5 13026 *cond_string = args;
5845583d
JB
13027
13028 args += strlen (args);
13029 }
13030
13031 /* Check that we do not have any more arguments. Anything else
13032 is unexpected. */
f7f9143b
JB
13033
13034 if (args[0] != '\0')
13035 error (_("Junk at end of expression"));
13036
9f757bf7
XR
13037 if (is_catch_handlers_cmd)
13038 {
13039 /* Catch handling of exceptions. */
13040 *ex = ada_catch_handlers;
13041 *excep_string = exception_name;
13042 }
bc18fbb5 13043 else if (exception_name.empty ())
f7f9143b
JB
13044 {
13045 /* Catch all exceptions. */
761269c8 13046 *ex = ada_catch_exception;
bc18fbb5 13047 excep_string->clear ();
f7f9143b 13048 }
bc18fbb5 13049 else if (exception_name == "unhandled")
f7f9143b
JB
13050 {
13051 /* Catch unhandled exceptions. */
761269c8 13052 *ex = ada_catch_exception_unhandled;
bc18fbb5 13053 excep_string->clear ();
f7f9143b
JB
13054 }
13055 else
13056 {
13057 /* Catch a specific exception. */
761269c8 13058 *ex = ada_catch_exception;
28010a5d 13059 *excep_string = exception_name;
f7f9143b
JB
13060 }
13061}
13062
13063/* Return the name of the symbol on which we should break in order to
13064 implement a catchpoint of the EX kind. */
13065
13066static const char *
761269c8 13067ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 13068{
3eecfa55
JB
13069 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13070
13071 gdb_assert (data->exception_info != NULL);
0259addd 13072
f7f9143b
JB
13073 switch (ex)
13074 {
761269c8 13075 case ada_catch_exception:
3eecfa55 13076 return (data->exception_info->catch_exception_sym);
f7f9143b 13077 break;
761269c8 13078 case ada_catch_exception_unhandled:
3eecfa55 13079 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 13080 break;
761269c8 13081 case ada_catch_assert:
3eecfa55 13082 return (data->exception_info->catch_assert_sym);
f7f9143b 13083 break;
9f757bf7
XR
13084 case ada_catch_handlers:
13085 return (data->exception_info->catch_handlers_sym);
13086 break;
f7f9143b
JB
13087 default:
13088 internal_error (__FILE__, __LINE__,
13089 _("unexpected catchpoint kind (%d)"), ex);
13090 }
13091}
13092
13093/* Return the breakpoint ops "virtual table" used for catchpoints
13094 of the EX kind. */
13095
c0a91b2b 13096static const struct breakpoint_ops *
761269c8 13097ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
13098{
13099 switch (ex)
13100 {
761269c8 13101 case ada_catch_exception:
f7f9143b
JB
13102 return (&catch_exception_breakpoint_ops);
13103 break;
761269c8 13104 case ada_catch_exception_unhandled:
f7f9143b
JB
13105 return (&catch_exception_unhandled_breakpoint_ops);
13106 break;
761269c8 13107 case ada_catch_assert:
f7f9143b
JB
13108 return (&catch_assert_breakpoint_ops);
13109 break;
9f757bf7
XR
13110 case ada_catch_handlers:
13111 return (&catch_handlers_breakpoint_ops);
13112 break;
f7f9143b
JB
13113 default:
13114 internal_error (__FILE__, __LINE__,
13115 _("unexpected catchpoint kind (%d)"), ex);
13116 }
13117}
13118
13119/* Return the condition that will be used to match the current exception
13120 being raised with the exception that the user wants to catch. This
13121 assumes that this condition is used when the inferior just triggered
13122 an exception catchpoint.
cb7de75e 13123 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 13124
cb7de75e 13125static std::string
9f757bf7
XR
13126ada_exception_catchpoint_cond_string (const char *excep_string,
13127 enum ada_exception_catchpoint_kind ex)
f7f9143b 13128{
3d0b0fa3 13129 int i;
9f757bf7 13130 bool is_standard_exc = false;
cb7de75e 13131 std::string result;
9f757bf7
XR
13132
13133 if (ex == ada_catch_handlers)
13134 {
13135 /* For exception handlers catchpoints, the condition string does
13136 not use the same parameter as for the other exceptions. */
cb7de75e
TT
13137 result = ("long_integer (GNAT_GCC_exception_Access"
13138 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13139 }
13140 else
cb7de75e 13141 result = "long_integer (e)";
3d0b0fa3 13142
0963b4bd 13143 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13144 runtime units that have been compiled without debugging info; if
28010a5d 13145 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13146 exception (e.g. "constraint_error") then, during the evaluation
13147 of the condition expression, the symbol lookup on this name would
0963b4bd 13148 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13149 may then be set only on user-defined exceptions which have the
13150 same not-fully-qualified name (e.g. my_package.constraint_error).
13151
13152 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13153 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13154 exception constraint_error" is rewritten into "catch exception
13155 standard.constraint_error".
13156
13157 If an exception named contraint_error is defined in another package of
13158 the inferior program, then the only way to specify this exception as a
13159 breakpoint condition is to use its fully-qualified named:
13160 e.g. my_package.constraint_error. */
13161
13162 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13163 {
28010a5d 13164 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13165 {
9f757bf7
XR
13166 is_standard_exc = true;
13167 break;
3d0b0fa3
JB
13168 }
13169 }
9f757bf7 13170
cb7de75e
TT
13171 result += " = ";
13172
9f757bf7 13173 if (is_standard_exc)
cb7de75e 13174 string_appendf (result, "long_integer (&standard.%s)", excep_string);
9f757bf7 13175 else
cb7de75e 13176 string_appendf (result, "long_integer (&%s)", excep_string);
9f757bf7 13177
9f757bf7 13178 return result;
f7f9143b
JB
13179}
13180
13181/* Return the symtab_and_line that should be used to insert an exception
13182 catchpoint of the TYPE kind.
13183
28010a5d
PA
13184 ADDR_STRING returns the name of the function where the real
13185 breakpoint that implements the catchpoints is set, depending on the
13186 type of catchpoint we need to create. */
f7f9143b
JB
13187
13188static struct symtab_and_line
bc18fbb5 13189ada_exception_sal (enum ada_exception_catchpoint_kind ex,
f2fc3015 13190 const char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13191{
13192 const char *sym_name;
13193 struct symbol *sym;
f7f9143b 13194
0259addd
JB
13195 /* First, find out which exception support info to use. */
13196 ada_exception_support_info_sniffer ();
13197
13198 /* Then lookup the function on which we will break in order to catch
f7f9143b 13199 the Ada exceptions requested by the user. */
f7f9143b
JB
13200 sym_name = ada_exception_sym_name (ex);
13201 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13202
57aff202
JB
13203 if (sym == NULL)
13204 error (_("Catchpoint symbol not found: %s"), sym_name);
13205
13206 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13207 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
f7f9143b
JB
13208
13209 /* Set ADDR_STRING. */
f7f9143b
JB
13210 *addr_string = xstrdup (sym_name);
13211
f7f9143b 13212 /* Set OPS. */
4b9eee8c 13213 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13214
f17011e0 13215 return find_function_start_sal (sym, 1);
f7f9143b
JB
13216}
13217
b4a5b78b 13218/* Create an Ada exception catchpoint.
f7f9143b 13219
b4a5b78b 13220 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13221
bc18fbb5 13222 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
2df4d1d5 13223 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
bc18fbb5 13224 of the exception to which this catchpoint applies.
2df4d1d5 13225
bc18fbb5 13226 COND_STRING, if not empty, is the catchpoint condition.
f7f9143b 13227
b4a5b78b
JB
13228 TEMPFLAG, if nonzero, means that the underlying breakpoint
13229 should be temporary.
28010a5d 13230
b4a5b78b 13231 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13232
349774ef 13233void
28010a5d 13234create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13235 enum ada_exception_catchpoint_kind ex_kind,
bc18fbb5 13236 const std::string &excep_string,
56ecd069 13237 const std::string &cond_string,
28010a5d 13238 int tempflag,
349774ef 13239 int disabled,
28010a5d
PA
13240 int from_tty)
13241{
f2fc3015 13242 const char *addr_string = NULL;
b4a5b78b 13243 const struct breakpoint_ops *ops = NULL;
bc18fbb5 13244 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
28010a5d 13245
b270e6f9
TT
13246 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13247 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
349774ef 13248 ops, tempflag, disabled, from_tty);
28010a5d 13249 c->excep_string = excep_string;
9f757bf7 13250 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13251 if (!cond_string.empty ())
13252 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13253 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13254}
13255
9ac4176b
PA
13256/* Implement the "catch exception" command. */
13257
13258static void
eb4c3f4a 13259catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13260 struct cmd_list_element *command)
13261{
a121b7c1 13262 const char *arg = arg_entry;
9ac4176b
PA
13263 struct gdbarch *gdbarch = get_current_arch ();
13264 int tempflag;
761269c8 13265 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13266 std::string excep_string;
56ecd069 13267 std::string cond_string;
9ac4176b
PA
13268
13269 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13270
13271 if (!arg)
13272 arg = "";
9f757bf7 13273 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
bc18fbb5 13274 &cond_string);
9f757bf7
XR
13275 create_ada_exception_catchpoint (gdbarch, ex_kind,
13276 excep_string, cond_string,
13277 tempflag, 1 /* enabled */,
13278 from_tty);
13279}
13280
13281/* Implement the "catch handlers" command. */
13282
13283static void
13284catch_ada_handlers_command (const char *arg_entry, int from_tty,
13285 struct cmd_list_element *command)
13286{
13287 const char *arg = arg_entry;
13288 struct gdbarch *gdbarch = get_current_arch ();
13289 int tempflag;
13290 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13291 std::string excep_string;
56ecd069 13292 std::string cond_string;
9f757bf7
XR
13293
13294 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13295
13296 if (!arg)
13297 arg = "";
13298 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
bc18fbb5 13299 &cond_string);
b4a5b78b
JB
13300 create_ada_exception_catchpoint (gdbarch, ex_kind,
13301 excep_string, cond_string,
349774ef
JB
13302 tempflag, 1 /* enabled */,
13303 from_tty);
9ac4176b
PA
13304}
13305
b4a5b78b 13306/* Split the arguments specified in a "catch assert" command.
5845583d 13307
b4a5b78b
JB
13308 ARGS contains the command's arguments (or the empty string if
13309 no arguments were passed).
5845583d
JB
13310
13311 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13312 (the memory needs to be deallocated after use). */
5845583d 13313
b4a5b78b 13314static void
56ecd069 13315catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13316{
f1735a53 13317 args = skip_spaces (args);
f7f9143b 13318
5845583d 13319 /* Check whether a condition was provided. */
61012eef 13320 if (startswith (args, "if")
5845583d 13321 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13322 {
5845583d 13323 args += 2;
f1735a53 13324 args = skip_spaces (args);
5845583d
JB
13325 if (args[0] == '\0')
13326 error (_("condition missing after `if' keyword"));
56ecd069 13327 cond_string.assign (args);
f7f9143b
JB
13328 }
13329
5845583d
JB
13330 /* Otherwise, there should be no other argument at the end of
13331 the command. */
13332 else if (args[0] != '\0')
13333 error (_("Junk at end of arguments."));
f7f9143b
JB
13334}
13335
9ac4176b
PA
13336/* Implement the "catch assert" command. */
13337
13338static void
eb4c3f4a 13339catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13340 struct cmd_list_element *command)
13341{
a121b7c1 13342 const char *arg = arg_entry;
9ac4176b
PA
13343 struct gdbarch *gdbarch = get_current_arch ();
13344 int tempflag;
56ecd069 13345 std::string cond_string;
9ac4176b
PA
13346
13347 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13348
13349 if (!arg)
13350 arg = "";
56ecd069 13351 catch_ada_assert_command_split (arg, cond_string);
761269c8 13352 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
241db429 13353 "", cond_string,
349774ef
JB
13354 tempflag, 1 /* enabled */,
13355 from_tty);
9ac4176b 13356}
778865d3
JB
13357
13358/* Return non-zero if the symbol SYM is an Ada exception object. */
13359
13360static int
13361ada_is_exception_sym (struct symbol *sym)
13362{
a737d952 13363 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
778865d3
JB
13364
13365 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13366 && SYMBOL_CLASS (sym) != LOC_BLOCK
13367 && SYMBOL_CLASS (sym) != LOC_CONST
13368 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13369 && type_name != NULL && strcmp (type_name, "exception") == 0);
13370}
13371
13372/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13373 Ada exception object. This matches all exceptions except the ones
13374 defined by the Ada language. */
13375
13376static int
13377ada_is_non_standard_exception_sym (struct symbol *sym)
13378{
13379 int i;
13380
13381 if (!ada_is_exception_sym (sym))
13382 return 0;
13383
13384 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13385 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13386 return 0; /* A standard exception. */
13387
13388 /* Numeric_Error is also a standard exception, so exclude it.
13389 See the STANDARD_EXC description for more details as to why
13390 this exception is not listed in that array. */
13391 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13392 return 0;
13393
13394 return 1;
13395}
13396
ab816a27 13397/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13398 objects.
13399
13400 The comparison is determined first by exception name, and then
13401 by exception address. */
13402
ab816a27 13403bool
cc536b21 13404ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13405{
778865d3
JB
13406 int result;
13407
ab816a27
TT
13408 result = strcmp (name, other.name);
13409 if (result < 0)
13410 return true;
13411 if (result == 0 && addr < other.addr)
13412 return true;
13413 return false;
13414}
778865d3 13415
ab816a27 13416bool
cc536b21 13417ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13418{
13419 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13420}
13421
13422/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13423 routine, but keeping the first SKIP elements untouched.
13424
13425 All duplicates are also removed. */
13426
13427static void
ab816a27 13428sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13429 int skip)
13430{
ab816a27
TT
13431 std::sort (exceptions->begin () + skip, exceptions->end ());
13432 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13433 exceptions->end ());
778865d3
JB
13434}
13435
778865d3
JB
13436/* Add all exceptions defined by the Ada standard whose name match
13437 a regular expression.
13438
13439 If PREG is not NULL, then this regexp_t object is used to
13440 perform the symbol name matching. Otherwise, no name-based
13441 filtering is performed.
13442
13443 EXCEPTIONS is a vector of exceptions to which matching exceptions
13444 gets pushed. */
13445
13446static void
2d7cc5c7 13447ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13448 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13449{
13450 int i;
13451
13452 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13453 {
13454 if (preg == NULL
2d7cc5c7 13455 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13456 {
13457 struct bound_minimal_symbol msymbol
13458 = ada_lookup_simple_minsym (standard_exc[i]);
13459
13460 if (msymbol.minsym != NULL)
13461 {
13462 struct ada_exc_info info
77e371c0 13463 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13464
ab816a27 13465 exceptions->push_back (info);
778865d3
JB
13466 }
13467 }
13468 }
13469}
13470
13471/* Add all Ada exceptions defined locally and accessible from the given
13472 FRAME.
13473
13474 If PREG is not NULL, then this regexp_t object is used to
13475 perform the symbol name matching. Otherwise, no name-based
13476 filtering is performed.
13477
13478 EXCEPTIONS is a vector of exceptions to which matching exceptions
13479 gets pushed. */
13480
13481static void
2d7cc5c7
PA
13482ada_add_exceptions_from_frame (compiled_regex *preg,
13483 struct frame_info *frame,
ab816a27 13484 std::vector<ada_exc_info> *exceptions)
778865d3 13485{
3977b71f 13486 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13487
13488 while (block != 0)
13489 {
13490 struct block_iterator iter;
13491 struct symbol *sym;
13492
13493 ALL_BLOCK_SYMBOLS (block, iter, sym)
13494 {
13495 switch (SYMBOL_CLASS (sym))
13496 {
13497 case LOC_TYPEDEF:
13498 case LOC_BLOCK:
13499 case LOC_CONST:
13500 break;
13501 default:
13502 if (ada_is_exception_sym (sym))
13503 {
13504 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13505 SYMBOL_VALUE_ADDRESS (sym)};
13506
ab816a27 13507 exceptions->push_back (info);
778865d3
JB
13508 }
13509 }
13510 }
13511 if (BLOCK_FUNCTION (block) != NULL)
13512 break;
13513 block = BLOCK_SUPERBLOCK (block);
13514 }
13515}
13516
14bc53a8
PA
13517/* Return true if NAME matches PREG or if PREG is NULL. */
13518
13519static bool
2d7cc5c7 13520name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13521{
13522 return (preg == NULL
2d7cc5c7 13523 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13524}
13525
778865d3
JB
13526/* Add all exceptions defined globally whose name name match
13527 a regular expression, excluding standard exceptions.
13528
13529 The reason we exclude standard exceptions is that they need
13530 to be handled separately: Standard exceptions are defined inside
13531 a runtime unit which is normally not compiled with debugging info,
13532 and thus usually do not show up in our symbol search. However,
13533 if the unit was in fact built with debugging info, we need to
13534 exclude them because they would duplicate the entry we found
13535 during the special loop that specifically searches for those
13536 standard exceptions.
13537
13538 If PREG is not NULL, then this regexp_t object is used to
13539 perform the symbol name matching. Otherwise, no name-based
13540 filtering is performed.
13541
13542 EXCEPTIONS is a vector of exceptions to which matching exceptions
13543 gets pushed. */
13544
13545static void
2d7cc5c7 13546ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13547 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13548{
13549 struct objfile *objfile;
43f3e411 13550 struct compunit_symtab *s;
778865d3 13551
14bc53a8
PA
13552 /* In Ada, the symbol "search name" is a linkage name, whereas the
13553 regular expression used to do the matching refers to the natural
13554 name. So match against the decoded name. */
13555 expand_symtabs_matching (NULL,
b5ec771e 13556 lookup_name_info::match_any (),
14bc53a8
PA
13557 [&] (const char *search_name)
13558 {
13559 const char *decoded = ada_decode (search_name);
13560 return name_matches_regex (decoded, preg);
13561 },
13562 NULL,
13563 VARIABLES_DOMAIN);
778865d3 13564
43f3e411 13565 ALL_COMPUNITS (objfile, s)
778865d3 13566 {
43f3e411 13567 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13568 int i;
13569
13570 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13571 {
13572 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13573 struct block_iterator iter;
13574 struct symbol *sym;
13575
13576 ALL_BLOCK_SYMBOLS (b, iter, sym)
13577 if (ada_is_non_standard_exception_sym (sym)
14bc53a8 13578 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
778865d3
JB
13579 {
13580 struct ada_exc_info info
13581 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13582
ab816a27 13583 exceptions->push_back (info);
778865d3
JB
13584 }
13585 }
13586 }
13587}
13588
13589/* Implements ada_exceptions_list with the regular expression passed
13590 as a regex_t, rather than a string.
13591
13592 If not NULL, PREG is used to filter out exceptions whose names
13593 do not match. Otherwise, all exceptions are listed. */
13594
ab816a27 13595static std::vector<ada_exc_info>
2d7cc5c7 13596ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13597{
ab816a27 13598 std::vector<ada_exc_info> result;
778865d3
JB
13599 int prev_len;
13600
13601 /* First, list the known standard exceptions. These exceptions
13602 need to be handled separately, as they are usually defined in
13603 runtime units that have been compiled without debugging info. */
13604
13605 ada_add_standard_exceptions (preg, &result);
13606
13607 /* Next, find all exceptions whose scope is local and accessible
13608 from the currently selected frame. */
13609
13610 if (has_stack_frames ())
13611 {
ab816a27 13612 prev_len = result.size ();
778865d3
JB
13613 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13614 &result);
ab816a27 13615 if (result.size () > prev_len)
778865d3
JB
13616 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13617 }
13618
13619 /* Add all exceptions whose scope is global. */
13620
ab816a27 13621 prev_len = result.size ();
778865d3 13622 ada_add_global_exceptions (preg, &result);
ab816a27 13623 if (result.size () > prev_len)
778865d3
JB
13624 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13625
778865d3
JB
13626 return result;
13627}
13628
13629/* Return a vector of ada_exc_info.
13630
13631 If REGEXP is NULL, all exceptions are included in the result.
13632 Otherwise, it should contain a valid regular expression,
13633 and only the exceptions whose names match that regular expression
13634 are included in the result.
13635
13636 The exceptions are sorted in the following order:
13637 - Standard exceptions (defined by the Ada language), in
13638 alphabetical order;
13639 - Exceptions only visible from the current frame, in
13640 alphabetical order;
13641 - Exceptions whose scope is global, in alphabetical order. */
13642
ab816a27 13643std::vector<ada_exc_info>
778865d3
JB
13644ada_exceptions_list (const char *regexp)
13645{
2d7cc5c7
PA
13646 if (regexp == NULL)
13647 return ada_exceptions_list_1 (NULL);
778865d3 13648
2d7cc5c7
PA
13649 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13650 return ada_exceptions_list_1 (&reg);
778865d3
JB
13651}
13652
13653/* Implement the "info exceptions" command. */
13654
13655static void
1d12d88f 13656info_exceptions_command (const char *regexp, int from_tty)
778865d3 13657{
778865d3 13658 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13659
ab816a27 13660 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13661
13662 if (regexp != NULL)
13663 printf_filtered
13664 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13665 else
13666 printf_filtered (_("All defined Ada exceptions:\n"));
13667
ab816a27
TT
13668 for (const ada_exc_info &info : exceptions)
13669 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13670}
13671
4c4b4cd2
PH
13672 /* Operators */
13673/* Information about operators given special treatment in functions
13674 below. */
13675/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13676
13677#define ADA_OPERATORS \
13678 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13679 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13680 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13681 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13682 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13683 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13684 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13685 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13686 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13687 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13688 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13689 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13690 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13691 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13692 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13693 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13694 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13695 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13696 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13697
13698static void
554794dc
SDJ
13699ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13700 int *argsp)
4c4b4cd2
PH
13701{
13702 switch (exp->elts[pc - 1].opcode)
13703 {
76a01679 13704 default:
4c4b4cd2
PH
13705 operator_length_standard (exp, pc, oplenp, argsp);
13706 break;
13707
13708#define OP_DEFN(op, len, args, binop) \
13709 case op: *oplenp = len; *argsp = args; break;
13710 ADA_OPERATORS;
13711#undef OP_DEFN
52ce6436
PH
13712
13713 case OP_AGGREGATE:
13714 *oplenp = 3;
13715 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13716 break;
13717
13718 case OP_CHOICES:
13719 *oplenp = 3;
13720 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13721 break;
4c4b4cd2
PH
13722 }
13723}
13724
c0201579
JK
13725/* Implementation of the exp_descriptor method operator_check. */
13726
13727static int
13728ada_operator_check (struct expression *exp, int pos,
13729 int (*objfile_func) (struct objfile *objfile, void *data),
13730 void *data)
13731{
13732 const union exp_element *const elts = exp->elts;
13733 struct type *type = NULL;
13734
13735 switch (elts[pos].opcode)
13736 {
13737 case UNOP_IN_RANGE:
13738 case UNOP_QUAL:
13739 type = elts[pos + 1].type;
13740 break;
13741
13742 default:
13743 return operator_check_standard (exp, pos, objfile_func, data);
13744 }
13745
13746 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13747
13748 if (type && TYPE_OBJFILE (type)
13749 && (*objfile_func) (TYPE_OBJFILE (type), data))
13750 return 1;
13751
13752 return 0;
13753}
13754
a121b7c1 13755static const char *
4c4b4cd2
PH
13756ada_op_name (enum exp_opcode opcode)
13757{
13758 switch (opcode)
13759 {
76a01679 13760 default:
4c4b4cd2 13761 return op_name_standard (opcode);
52ce6436 13762
4c4b4cd2
PH
13763#define OP_DEFN(op, len, args, binop) case op: return #op;
13764 ADA_OPERATORS;
13765#undef OP_DEFN
52ce6436
PH
13766
13767 case OP_AGGREGATE:
13768 return "OP_AGGREGATE";
13769 case OP_CHOICES:
13770 return "OP_CHOICES";
13771 case OP_NAME:
13772 return "OP_NAME";
4c4b4cd2
PH
13773 }
13774}
13775
13776/* As for operator_length, but assumes PC is pointing at the first
13777 element of the operator, and gives meaningful results only for the
52ce6436 13778 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13779
13780static void
76a01679
JB
13781ada_forward_operator_length (struct expression *exp, int pc,
13782 int *oplenp, int *argsp)
4c4b4cd2 13783{
76a01679 13784 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13785 {
13786 default:
13787 *oplenp = *argsp = 0;
13788 break;
52ce6436 13789
4c4b4cd2
PH
13790#define OP_DEFN(op, len, args, binop) \
13791 case op: *oplenp = len; *argsp = args; break;
13792 ADA_OPERATORS;
13793#undef OP_DEFN
52ce6436
PH
13794
13795 case OP_AGGREGATE:
13796 *oplenp = 3;
13797 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13798 break;
13799
13800 case OP_CHOICES:
13801 *oplenp = 3;
13802 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13803 break;
13804
13805 case OP_STRING:
13806 case OP_NAME:
13807 {
13808 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13809
52ce6436
PH
13810 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13811 *argsp = 0;
13812 break;
13813 }
4c4b4cd2
PH
13814 }
13815}
13816
13817static int
13818ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13819{
13820 enum exp_opcode op = exp->elts[elt].opcode;
13821 int oplen, nargs;
13822 int pc = elt;
13823 int i;
76a01679 13824
4c4b4cd2
PH
13825 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13826
76a01679 13827 switch (op)
4c4b4cd2 13828 {
76a01679 13829 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13830 case OP_ATR_FIRST:
13831 case OP_ATR_LAST:
13832 case OP_ATR_LENGTH:
13833 case OP_ATR_IMAGE:
13834 case OP_ATR_MAX:
13835 case OP_ATR_MIN:
13836 case OP_ATR_MODULUS:
13837 case OP_ATR_POS:
13838 case OP_ATR_SIZE:
13839 case OP_ATR_TAG:
13840 case OP_ATR_VAL:
13841 break;
13842
13843 case UNOP_IN_RANGE:
13844 case UNOP_QUAL:
323e0a4a
AC
13845 /* XXX: gdb_sprint_host_address, type_sprint */
13846 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13847 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13848 fprintf_filtered (stream, " (");
13849 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13850 fprintf_filtered (stream, ")");
13851 break;
13852 case BINOP_IN_BOUNDS:
52ce6436
PH
13853 fprintf_filtered (stream, " (%d)",
13854 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13855 break;
13856 case TERNOP_IN_RANGE:
13857 break;
13858
52ce6436
PH
13859 case OP_AGGREGATE:
13860 case OP_OTHERS:
13861 case OP_DISCRETE_RANGE:
13862 case OP_POSITIONAL:
13863 case OP_CHOICES:
13864 break;
13865
13866 case OP_NAME:
13867 case OP_STRING:
13868 {
13869 char *name = &exp->elts[elt + 2].string;
13870 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13871
52ce6436
PH
13872 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13873 break;
13874 }
13875
4c4b4cd2
PH
13876 default:
13877 return dump_subexp_body_standard (exp, stream, elt);
13878 }
13879
13880 elt += oplen;
13881 for (i = 0; i < nargs; i += 1)
13882 elt = dump_subexp (exp, stream, elt);
13883
13884 return elt;
13885}
13886
13887/* The Ada extension of print_subexp (q.v.). */
13888
76a01679
JB
13889static void
13890ada_print_subexp (struct expression *exp, int *pos,
13891 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13892{
52ce6436 13893 int oplen, nargs, i;
4c4b4cd2
PH
13894 int pc = *pos;
13895 enum exp_opcode op = exp->elts[pc].opcode;
13896
13897 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13898
52ce6436 13899 *pos += oplen;
4c4b4cd2
PH
13900 switch (op)
13901 {
13902 default:
52ce6436 13903 *pos -= oplen;
4c4b4cd2
PH
13904 print_subexp_standard (exp, pos, stream, prec);
13905 return;
13906
13907 case OP_VAR_VALUE:
4c4b4cd2
PH
13908 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13909 return;
13910
13911 case BINOP_IN_BOUNDS:
323e0a4a 13912 /* XXX: sprint_subexp */
4c4b4cd2 13913 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13914 fputs_filtered (" in ", stream);
4c4b4cd2 13915 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13916 fputs_filtered ("'range", stream);
4c4b4cd2 13917 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13918 fprintf_filtered (stream, "(%ld)",
13919 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13920 return;
13921
13922 case TERNOP_IN_RANGE:
4c4b4cd2 13923 if (prec >= PREC_EQUAL)
76a01679 13924 fputs_filtered ("(", stream);
323e0a4a 13925 /* XXX: sprint_subexp */
4c4b4cd2 13926 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13927 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13928 print_subexp (exp, pos, stream, PREC_EQUAL);
13929 fputs_filtered (" .. ", stream);
13930 print_subexp (exp, pos, stream, PREC_EQUAL);
13931 if (prec >= PREC_EQUAL)
76a01679
JB
13932 fputs_filtered (")", stream);
13933 return;
4c4b4cd2
PH
13934
13935 case OP_ATR_FIRST:
13936 case OP_ATR_LAST:
13937 case OP_ATR_LENGTH:
13938 case OP_ATR_IMAGE:
13939 case OP_ATR_MAX:
13940 case OP_ATR_MIN:
13941 case OP_ATR_MODULUS:
13942 case OP_ATR_POS:
13943 case OP_ATR_SIZE:
13944 case OP_ATR_TAG:
13945 case OP_ATR_VAL:
4c4b4cd2 13946 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13947 {
13948 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13949 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13950 &type_print_raw_options);
76a01679
JB
13951 *pos += 3;
13952 }
4c4b4cd2 13953 else
76a01679 13954 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13955 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13956 if (nargs > 1)
76a01679
JB
13957 {
13958 int tem;
5b4ee69b 13959
76a01679
JB
13960 for (tem = 1; tem < nargs; tem += 1)
13961 {
13962 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13963 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13964 }
13965 fputs_filtered (")", stream);
13966 }
4c4b4cd2 13967 return;
14f9c5c9 13968
4c4b4cd2 13969 case UNOP_QUAL:
4c4b4cd2
PH
13970 type_print (exp->elts[pc + 1].type, "", stream, 0);
13971 fputs_filtered ("'(", stream);
13972 print_subexp (exp, pos, stream, PREC_PREFIX);
13973 fputs_filtered (")", stream);
13974 return;
14f9c5c9 13975
4c4b4cd2 13976 case UNOP_IN_RANGE:
323e0a4a 13977 /* XXX: sprint_subexp */
4c4b4cd2 13978 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13979 fputs_filtered (" in ", stream);
79d43c61
TT
13980 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13981 &type_print_raw_options);
4c4b4cd2 13982 return;
52ce6436
PH
13983
13984 case OP_DISCRETE_RANGE:
13985 print_subexp (exp, pos, stream, PREC_SUFFIX);
13986 fputs_filtered ("..", stream);
13987 print_subexp (exp, pos, stream, PREC_SUFFIX);
13988 return;
13989
13990 case OP_OTHERS:
13991 fputs_filtered ("others => ", stream);
13992 print_subexp (exp, pos, stream, PREC_SUFFIX);
13993 return;
13994
13995 case OP_CHOICES:
13996 for (i = 0; i < nargs-1; i += 1)
13997 {
13998 if (i > 0)
13999 fputs_filtered ("|", stream);
14000 print_subexp (exp, pos, stream, PREC_SUFFIX);
14001 }
14002 fputs_filtered (" => ", stream);
14003 print_subexp (exp, pos, stream, PREC_SUFFIX);
14004 return;
14005
14006 case OP_POSITIONAL:
14007 print_subexp (exp, pos, stream, PREC_SUFFIX);
14008 return;
14009
14010 case OP_AGGREGATE:
14011 fputs_filtered ("(", stream);
14012 for (i = 0; i < nargs; i += 1)
14013 {
14014 if (i > 0)
14015 fputs_filtered (", ", stream);
14016 print_subexp (exp, pos, stream, PREC_SUFFIX);
14017 }
14018 fputs_filtered (")", stream);
14019 return;
4c4b4cd2
PH
14020 }
14021}
14f9c5c9
AS
14022
14023/* Table mapping opcodes into strings for printing operators
14024 and precedences of the operators. */
14025
d2e4a39e
AS
14026static const struct op_print ada_op_print_tab[] = {
14027 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14028 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14029 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14030 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14031 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14032 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14033 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14034 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14035 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14036 {">=", BINOP_GEQ, PREC_ORDER, 0},
14037 {">", BINOP_GTR, PREC_ORDER, 0},
14038 {"<", BINOP_LESS, PREC_ORDER, 0},
14039 {">>", BINOP_RSH, PREC_SHIFT, 0},
14040 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14041 {"+", BINOP_ADD, PREC_ADD, 0},
14042 {"-", BINOP_SUB, PREC_ADD, 0},
14043 {"&", BINOP_CONCAT, PREC_ADD, 0},
14044 {"*", BINOP_MUL, PREC_MUL, 0},
14045 {"/", BINOP_DIV, PREC_MUL, 0},
14046 {"rem", BINOP_REM, PREC_MUL, 0},
14047 {"mod", BINOP_MOD, PREC_MUL, 0},
14048 {"**", BINOP_EXP, PREC_REPEAT, 0},
14049 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14050 {"-", UNOP_NEG, PREC_PREFIX, 0},
14051 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14052 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14053 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14054 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
14055 {".all", UNOP_IND, PREC_SUFFIX, 1},
14056 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14057 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 14058 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
14059};
14060\f
72d5681a
PH
14061enum ada_primitive_types {
14062 ada_primitive_type_int,
14063 ada_primitive_type_long,
14064 ada_primitive_type_short,
14065 ada_primitive_type_char,
14066 ada_primitive_type_float,
14067 ada_primitive_type_double,
14068 ada_primitive_type_void,
14069 ada_primitive_type_long_long,
14070 ada_primitive_type_long_double,
14071 ada_primitive_type_natural,
14072 ada_primitive_type_positive,
14073 ada_primitive_type_system_address,
08f49010 14074 ada_primitive_type_storage_offset,
72d5681a
PH
14075 nr_ada_primitive_types
14076};
6c038f32
PH
14077
14078static void
d4a9a881 14079ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
14080 struct language_arch_info *lai)
14081{
d4a9a881 14082 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 14083
72d5681a 14084 lai->primitive_type_vector
d4a9a881 14085 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 14086 struct type *);
e9bb382b
UW
14087
14088 lai->primitive_type_vector [ada_primitive_type_int]
14089 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14090 0, "integer");
14091 lai->primitive_type_vector [ada_primitive_type_long]
14092 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14093 0, "long_integer");
14094 lai->primitive_type_vector [ada_primitive_type_short]
14095 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14096 0, "short_integer");
14097 lai->string_char_type
14098 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 14099 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
14100 lai->primitive_type_vector [ada_primitive_type_float]
14101 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 14102 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
14103 lai->primitive_type_vector [ada_primitive_type_double]
14104 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14105 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14106 lai->primitive_type_vector [ada_primitive_type_long_long]
14107 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14108 0, "long_long_integer");
14109 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14110 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14111 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14112 lai->primitive_type_vector [ada_primitive_type_natural]
14113 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14114 0, "natural");
14115 lai->primitive_type_vector [ada_primitive_type_positive]
14116 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14117 0, "positive");
14118 lai->primitive_type_vector [ada_primitive_type_void]
14119 = builtin->builtin_void;
14120
14121 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14122 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14123 "void"));
72d5681a
PH
14124 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14125 = "system__address";
fbb06eb1 14126
08f49010
XR
14127 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14128 type. This is a signed integral type whose size is the same as
14129 the size of addresses. */
14130 {
14131 unsigned int addr_length = TYPE_LENGTH
14132 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14133
14134 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14135 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14136 "storage_offset");
14137 }
14138
47e729a8 14139 lai->bool_type_symbol = NULL;
fbb06eb1 14140 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14141}
6c038f32
PH
14142\f
14143 /* Language vector */
14144
14145/* Not really used, but needed in the ada_language_defn. */
14146
14147static void
6c7a06a3 14148emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14149{
6c7a06a3 14150 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14151}
14152
14153static int
410a0ff2 14154parse (struct parser_state *ps)
6c038f32
PH
14155{
14156 warnings_issued = 0;
410a0ff2 14157 return ada_parse (ps);
6c038f32
PH
14158}
14159
14160static const struct exp_descriptor ada_exp_descriptor = {
14161 ada_print_subexp,
14162 ada_operator_length,
c0201579 14163 ada_operator_check,
6c038f32
PH
14164 ada_op_name,
14165 ada_dump_subexp_body,
14166 ada_evaluate_subexp
14167};
14168
b5ec771e
PA
14169/* symbol_name_matcher_ftype adapter for wild_match. */
14170
14171static bool
14172do_wild_match (const char *symbol_search_name,
14173 const lookup_name_info &lookup_name,
a207cff2 14174 completion_match_result *comp_match_res)
b5ec771e
PA
14175{
14176 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14177}
14178
14179/* symbol_name_matcher_ftype adapter for full_match. */
14180
14181static bool
14182do_full_match (const char *symbol_search_name,
14183 const lookup_name_info &lookup_name,
a207cff2 14184 completion_match_result *comp_match_res)
b5ec771e
PA
14185{
14186 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14187}
14188
14189/* Build the Ada lookup name for LOOKUP_NAME. */
14190
14191ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14192{
14193 const std::string &user_name = lookup_name.name ();
14194
14195 if (user_name[0] == '<')
14196 {
14197 if (user_name.back () == '>')
14198 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14199 else
14200 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14201 m_encoded_p = true;
14202 m_verbatim_p = true;
14203 m_wild_match_p = false;
14204 m_standard_p = false;
14205 }
14206 else
14207 {
14208 m_verbatim_p = false;
14209
14210 m_encoded_p = user_name.find ("__") != std::string::npos;
14211
14212 if (!m_encoded_p)
14213 {
14214 const char *folded = ada_fold_name (user_name.c_str ());
14215 const char *encoded = ada_encode_1 (folded, false);
14216 if (encoded != NULL)
14217 m_encoded_name = encoded;
14218 else
14219 m_encoded_name = user_name;
14220 }
14221 else
14222 m_encoded_name = user_name;
14223
14224 /* Handle the 'package Standard' special case. See description
14225 of m_standard_p. */
14226 if (startswith (m_encoded_name.c_str (), "standard__"))
14227 {
14228 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14229 m_standard_p = true;
14230 }
14231 else
14232 m_standard_p = false;
74ccd7f5 14233
b5ec771e
PA
14234 /* If the name contains a ".", then the user is entering a fully
14235 qualified entity name, and the match must not be done in wild
14236 mode. Similarly, if the user wants to complete what looks
14237 like an encoded name, the match must not be done in wild
14238 mode. Also, in the standard__ special case always do
14239 non-wild matching. */
14240 m_wild_match_p
14241 = (lookup_name.match_type () != symbol_name_match_type::FULL
14242 && !m_encoded_p
14243 && !m_standard_p
14244 && user_name.find ('.') == std::string::npos);
14245 }
14246}
14247
14248/* symbol_name_matcher_ftype method for Ada. This only handles
14249 completion mode. */
14250
14251static bool
14252ada_symbol_name_matches (const char *symbol_search_name,
14253 const lookup_name_info &lookup_name,
a207cff2 14254 completion_match_result *comp_match_res)
74ccd7f5 14255{
b5ec771e
PA
14256 return lookup_name.ada ().matches (symbol_search_name,
14257 lookup_name.match_type (),
a207cff2 14258 comp_match_res);
b5ec771e
PA
14259}
14260
de63c46b
PA
14261/* A name matcher that matches the symbol name exactly, with
14262 strcmp. */
14263
14264static bool
14265literal_symbol_name_matcher (const char *symbol_search_name,
14266 const lookup_name_info &lookup_name,
14267 completion_match_result *comp_match_res)
14268{
14269 const std::string &name = lookup_name.name ();
14270
14271 int cmp = (lookup_name.completion_mode ()
14272 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14273 : strcmp (symbol_search_name, name.c_str ()));
14274 if (cmp == 0)
14275 {
14276 if (comp_match_res != NULL)
14277 comp_match_res->set_match (symbol_search_name);
14278 return true;
14279 }
14280 else
14281 return false;
14282}
14283
b5ec771e
PA
14284/* Implement the "la_get_symbol_name_matcher" language_defn method for
14285 Ada. */
14286
14287static symbol_name_matcher_ftype *
14288ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14289{
de63c46b
PA
14290 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14291 return literal_symbol_name_matcher;
14292
b5ec771e
PA
14293 if (lookup_name.completion_mode ())
14294 return ada_symbol_name_matches;
74ccd7f5 14295 else
b5ec771e
PA
14296 {
14297 if (lookup_name.ada ().wild_match_p ())
14298 return do_wild_match;
14299 else
14300 return do_full_match;
14301 }
74ccd7f5
JB
14302}
14303
a5ee536b
JB
14304/* Implement the "la_read_var_value" language_defn method for Ada. */
14305
14306static struct value *
63e43d3a
PMR
14307ada_read_var_value (struct symbol *var, const struct block *var_block,
14308 struct frame_info *frame)
a5ee536b 14309{
3977b71f 14310 const struct block *frame_block = NULL;
a5ee536b
JB
14311 struct symbol *renaming_sym = NULL;
14312
14313 /* The only case where default_read_var_value is not sufficient
14314 is when VAR is a renaming... */
14315 if (frame)
14316 frame_block = get_frame_block (frame, NULL);
14317 if (frame_block)
14318 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14319 if (renaming_sym != NULL)
14320 return ada_read_renaming_var_value (renaming_sym, frame_block);
14321
14322 /* This is a typical case where we expect the default_read_var_value
14323 function to work. */
63e43d3a 14324 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14325}
14326
56618e20
TT
14327static const char *ada_extensions[] =
14328{
14329 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14330};
14331
47e77640 14332extern const struct language_defn ada_language_defn = {
6c038f32 14333 "ada", /* Language name */
6abde28f 14334 "Ada",
6c038f32 14335 language_ada,
6c038f32 14336 range_check_off,
6c038f32
PH
14337 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14338 that's not quite what this means. */
6c038f32 14339 array_row_major,
9a044a89 14340 macro_expansion_no,
56618e20 14341 ada_extensions,
6c038f32
PH
14342 &ada_exp_descriptor,
14343 parse,
6c038f32
PH
14344 resolve,
14345 ada_printchar, /* Print a character constant */
14346 ada_printstr, /* Function to print string constant */
14347 emit_char, /* Function to print single char (not used) */
6c038f32 14348 ada_print_type, /* Print a type using appropriate syntax */
be942545 14349 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14350 ada_val_print, /* Print a value using appropriate syntax */
14351 ada_value_print, /* Print a top-level value */
a5ee536b 14352 ada_read_var_value, /* la_read_var_value */
6c038f32 14353 NULL, /* Language specific skip_trampoline */
2b2d9e11 14354 NULL, /* name_of_this */
59cc4834 14355 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14356 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14357 basic_lookup_transparent_type, /* lookup_transparent_type */
14358 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14359 ada_sniff_from_mangled_name,
0963b4bd
MS
14360 NULL, /* Language specific
14361 class_name_from_physname */
6c038f32
PH
14362 ada_op_print_tab, /* expression operators for printing */
14363 0, /* c-style arrays */
14364 1, /* String lower bound */
6c038f32 14365 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14366 ada_collect_symbol_completion_matches,
72d5681a 14367 ada_language_arch_info,
e79af960 14368 ada_print_array_index,
41f1b697 14369 default_pass_by_reference,
ae6a3a4c 14370 c_get_string,
e2b7af72 14371 ada_watch_location_expression,
b5ec771e 14372 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14373 ada_iterate_over_symbols,
5ffa0793 14374 default_search_name_hash,
a53b64ea 14375 &ada_varobj_ops,
bb2ec1b3
TT
14376 NULL,
14377 NULL,
6c038f32
PH
14378 LANG_MAGIC
14379};
14380
5bf03f13
JB
14381/* Command-list for the "set/show ada" prefix command. */
14382static struct cmd_list_element *set_ada_list;
14383static struct cmd_list_element *show_ada_list;
14384
14385/* Implement the "set ada" prefix command. */
14386
14387static void
981a3fb3 14388set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14389{
14390 printf_unfiltered (_(\
14391"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14392 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14393}
14394
14395/* Implement the "show ada" prefix command. */
14396
14397static void
981a3fb3 14398show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14399{
14400 cmd_show_list (show_ada_list, from_tty, "");
14401}
14402
2060206e
PA
14403static void
14404initialize_ada_catchpoint_ops (void)
14405{
14406 struct breakpoint_ops *ops;
14407
14408 initialize_breakpoint_ops ();
14409
14410 ops = &catch_exception_breakpoint_ops;
14411 *ops = bkpt_breakpoint_ops;
2060206e
PA
14412 ops->allocate_location = allocate_location_catch_exception;
14413 ops->re_set = re_set_catch_exception;
14414 ops->check_status = check_status_catch_exception;
14415 ops->print_it = print_it_catch_exception;
14416 ops->print_one = print_one_catch_exception;
14417 ops->print_mention = print_mention_catch_exception;
14418 ops->print_recreate = print_recreate_catch_exception;
14419
14420 ops = &catch_exception_unhandled_breakpoint_ops;
14421 *ops = bkpt_breakpoint_ops;
2060206e
PA
14422 ops->allocate_location = allocate_location_catch_exception_unhandled;
14423 ops->re_set = re_set_catch_exception_unhandled;
14424 ops->check_status = check_status_catch_exception_unhandled;
14425 ops->print_it = print_it_catch_exception_unhandled;
14426 ops->print_one = print_one_catch_exception_unhandled;
14427 ops->print_mention = print_mention_catch_exception_unhandled;
14428 ops->print_recreate = print_recreate_catch_exception_unhandled;
14429
14430 ops = &catch_assert_breakpoint_ops;
14431 *ops = bkpt_breakpoint_ops;
2060206e
PA
14432 ops->allocate_location = allocate_location_catch_assert;
14433 ops->re_set = re_set_catch_assert;
14434 ops->check_status = check_status_catch_assert;
14435 ops->print_it = print_it_catch_assert;
14436 ops->print_one = print_one_catch_assert;
14437 ops->print_mention = print_mention_catch_assert;
14438 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14439
14440 ops = &catch_handlers_breakpoint_ops;
14441 *ops = bkpt_breakpoint_ops;
14442 ops->allocate_location = allocate_location_catch_handlers;
14443 ops->re_set = re_set_catch_handlers;
14444 ops->check_status = check_status_catch_handlers;
14445 ops->print_it = print_it_catch_handlers;
14446 ops->print_one = print_one_catch_handlers;
14447 ops->print_mention = print_mention_catch_handlers;
14448 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14449}
14450
3d9434b5
JB
14451/* This module's 'new_objfile' observer. */
14452
14453static void
14454ada_new_objfile_observer (struct objfile *objfile)
14455{
14456 ada_clear_symbol_cache ();
14457}
14458
14459/* This module's 'free_objfile' observer. */
14460
14461static void
14462ada_free_objfile_observer (struct objfile *objfile)
14463{
14464 ada_clear_symbol_cache ();
14465}
14466
d2e4a39e 14467void
6c038f32 14468_initialize_ada_language (void)
14f9c5c9 14469{
2060206e
PA
14470 initialize_ada_catchpoint_ops ();
14471
5bf03f13 14472 add_prefix_cmd ("ada", no_class, set_ada_command,
470678d7 14473 _("Prefix command for changing Ada-specific settings"),
5bf03f13
JB
14474 &set_ada_list, "set ada ", 0, &setlist);
14475
14476 add_prefix_cmd ("ada", no_class, show_ada_command,
14477 _("Generic command for showing Ada-specific settings."),
14478 &show_ada_list, "show ada ", 0, &showlist);
14479
14480 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14481 &trust_pad_over_xvs, _("\
14482Enable or disable an optimization trusting PAD types over XVS types"), _("\
14483Show whether an optimization trusting PAD types over XVS types is activated"),
14484 _("\
14485This is related to the encoding used by the GNAT compiler. The debugger\n\
14486should normally trust the contents of PAD types, but certain older versions\n\
14487of GNAT have a bug that sometimes causes the information in the PAD type\n\
14488to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14489work around this bug. It is always safe to turn this option \"off\", but\n\
14490this incurs a slight performance penalty, so it is recommended to NOT change\n\
14491this option to \"off\" unless necessary."),
14492 NULL, NULL, &set_ada_list, &show_ada_list);
14493
d72413e6
PMR
14494 add_setshow_boolean_cmd ("print-signatures", class_vars,
14495 &print_signatures, _("\
14496Enable or disable the output of formal and return types for functions in the \
14497overloads selection menu"), _("\
14498Show whether the output of formal and return types for functions in the \
14499overloads selection menu is activated"),
14500 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14501
9ac4176b
PA
14502 add_catch_command ("exception", _("\
14503Catch Ada exceptions, when raised.\n\
14504With an argument, catch only exceptions with the given name."),
14505 catch_ada_exception_command,
14506 NULL,
14507 CATCH_PERMANENT,
14508 CATCH_TEMPORARY);
9f757bf7
XR
14509
14510 add_catch_command ("handlers", _("\
14511Catch Ada exceptions, when handled.\n\
14512With an argument, catch only exceptions with the given name."),
14513 catch_ada_handlers_command,
14514 NULL,
14515 CATCH_PERMANENT,
14516 CATCH_TEMPORARY);
9ac4176b
PA
14517 add_catch_command ("assert", _("\
14518Catch failed Ada assertions, when raised.\n\
14519With an argument, catch only exceptions with the given name."),
14520 catch_assert_command,
14521 NULL,
14522 CATCH_PERMANENT,
14523 CATCH_TEMPORARY);
14524
6c038f32 14525 varsize_limit = 65536;
3fcded8f
JB
14526 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14527 &varsize_limit, _("\
14528Set the maximum number of bytes allowed in a variable-size object."), _("\
14529Show the maximum number of bytes allowed in a variable-size object."), _("\
14530Attempts to access an object whose size is not a compile-time constant\n\
14531and exceeds this limit will cause an error."),
14532 NULL, NULL, &setlist, &showlist);
6c038f32 14533
778865d3
JB
14534 add_info ("exceptions", info_exceptions_command,
14535 _("\
14536List all Ada exception names.\n\
14537If a regular expression is passed as an argument, only those matching\n\
14538the regular expression are listed."));
14539
c6044dd1
JB
14540 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14541 _("Set Ada maintenance-related variables."),
14542 &maint_set_ada_cmdlist, "maintenance set ada ",
14543 0/*allow-unknown*/, &maintenance_set_cmdlist);
14544
14545 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14546 _("Show Ada maintenance-related variables"),
14547 &maint_show_ada_cmdlist, "maintenance show ada ",
14548 0/*allow-unknown*/, &maintenance_show_cmdlist);
14549
14550 add_setshow_boolean_cmd
14551 ("ignore-descriptive-types", class_maintenance,
14552 &ada_ignore_descriptive_types_p,
14553 _("Set whether descriptive types generated by GNAT should be ignored."),
14554 _("Show whether descriptive types generated by GNAT should be ignored."),
14555 _("\
14556When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14557DWARF attribute."),
14558 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14559
459a2e4c
TT
14560 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14561 NULL, xcalloc, xfree);
6b69afc4 14562
3d9434b5 14563 /* The ada-lang observers. */
76727919
TT
14564 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14565 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14566 gdb::observers::inferior_exit.attach (ada_inferior_exit);
ee01b665
JB
14567
14568 /* Setup various context-specific data. */
e802dbe0 14569 ada_inferior_data
8e260fc0 14570 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14571 ada_pspace_data_handle
14572 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14573}