]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
(Ada) "catch assert" spurious internal error
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
e2882c85 3 Copyright (C) 1992-2018 Free Software Foundation, Inc.
14f9c5c9 4
a9762ec7 5 This file is part of GDB.
14f9c5c9 6
a9762ec7
JB
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
14f9c5c9 11
a9762ec7
JB
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
14f9c5c9 16
a9762ec7
JB
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 19
96d887e8 20
4c4b4cd2 21#include "defs.h"
14f9c5c9 22#include <ctype.h>
14f9c5c9 23#include "demangle.h"
4c4b4cd2
PH
24#include "gdb_regex.h"
25#include "frame.h"
14f9c5c9
AS
26#include "symtab.h"
27#include "gdbtypes.h"
28#include "gdbcmd.h"
29#include "expression.h"
30#include "parser-defs.h"
31#include "language.h"
a53b64ea 32#include "varobj.h"
14f9c5c9
AS
33#include "c-lang.h"
34#include "inferior.h"
35#include "symfile.h"
36#include "objfiles.h"
37#include "breakpoint.h"
38#include "gdbcore.h"
4c4b4cd2
PH
39#include "hashtab.h"
40#include "gdb_obstack.h"
14f9c5c9 41#include "ada-lang.h"
4c4b4cd2 42#include "completer.h"
53ce3c39 43#include <sys/stat.h>
14f9c5c9 44#include "ui-out.h"
fe898f56 45#include "block.h"
04714b91 46#include "infcall.h"
de4f826b 47#include "dictionary.h"
f7f9143b
JB
48#include "annotate.h"
49#include "valprint.h"
9bbc9174 50#include "source.h"
76727919 51#include "observable.h"
2ba95b9b 52#include "vec.h"
692465f1 53#include "stack.h"
fa864999 54#include "gdb_vecs.h"
79d43c61 55#include "typeprint.h"
22cee43f 56#include "namespace.h"
14f9c5c9 57
ccefe4c4 58#include "psymtab.h"
40bc484c 59#include "value.h"
956a9fb9 60#include "mi/mi-common.h"
9ac4176b 61#include "arch-utils.h"
0fcd72ba 62#include "cli/cli-utils.h"
14bc53a8 63#include "common/function-view.h"
d5722aa2 64#include "common/byte-vector.h"
ab816a27 65#include <algorithm>
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40bc484c 107static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 108
4c4b4cd2 109static void ada_add_block_symbols (struct obstack *,
b5ec771e
PA
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
14f9c5c9 113
22cee43f 114static void ada_add_all_symbols (struct obstack *, const struct block *,
b5ec771e
PA
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
22cee43f 117
d12307c1 118static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 119
76a01679 120static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 121 const struct block *);
14f9c5c9 122
4c4b4cd2
PH
123static int num_defns_collected (struct obstack *);
124
d12307c1 125static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 126
e9d9f57e 127static struct value *resolve_subexp (expression_up *, int *, int,
76a01679 128 struct type *);
14f9c5c9 129
e9d9f57e 130static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 131 struct symbol *, const struct block *);
14f9c5c9 132
d2e4a39e 133static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 134
a121b7c1 135static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
136
137static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 138
d2e4a39e 139static int numeric_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int integer_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int scalar_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int discrete_type_p (struct type *);
14f9c5c9 146
aeb5907d
JB
147static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 153 const struct block *);
aeb5907d 154
a121b7c1 155static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 156 int, int);
4c4b4cd2 157
d2e4a39e 158static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 159
b4ba55a1
JB
160static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
d2e4a39e 163static int is_dynamic_field (struct type *, int);
14f9c5c9 164
10a2c479 165static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 166 const gdb_byte *,
4c4b4cd2
PH
167 CORE_ADDR, struct value *);
168
169static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 170
28c85d6c 171static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 172
d2e4a39e 173static struct type *to_static_fixed_type (struct type *);
f192137b 174static struct type *static_unwrap_type (struct type *type);
14f9c5c9 175
d2e4a39e 176static struct value *unwrap_value (struct value *);
14f9c5c9 177
ad82864c 178static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 179
ad82864c 180static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 181
ad82864c
JB
182static long decode_packed_array_bitsize (struct type *);
183
184static struct value *decode_constrained_packed_array (struct value *);
185
186static int ada_is_packed_array_type (struct type *);
187
188static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 189
d2e4a39e 190static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 191 struct value **);
14f9c5c9 192
50810684 193static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 194
4c4b4cd2
PH
195static struct value *coerce_unspec_val_to_type (struct value *,
196 struct type *);
14f9c5c9 197
d2e4a39e 198static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 199
d2e4a39e 200static int equiv_types (struct type *, struct type *);
14f9c5c9 201
d2e4a39e 202static int is_name_suffix (const char *);
14f9c5c9 203
73589123
PH
204static int advance_wild_match (const char **, const char *, int);
205
b5ec771e 206static bool wild_match (const char *name, const char *patn);
14f9c5c9 207
d2e4a39e 208static struct value *ada_coerce_ref (struct value *);
14f9c5c9 209
4c4b4cd2
PH
210static LONGEST pos_atr (struct value *);
211
3cb382c9 212static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 213
d2e4a39e 214static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 215
4c4b4cd2
PH
216static struct symbol *standard_lookup (const char *, const struct block *,
217 domain_enum);
14f9c5c9 218
108d56a4 219static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
220 struct type *);
221
222static struct value *ada_value_primitive_field (struct value *, int, int,
223 struct type *);
224
0d5cff50 225static int find_struct_field (const char *, struct type *, int,
52ce6436 226 struct type **, int *, int *, int *, int *);
4c4b4cd2 227
d12307c1 228static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
229 struct value **, int, const char *,
230 struct type *);
231
4c4b4cd2
PH
232static int ada_is_direct_array_type (struct type *);
233
72d5681a
PH
234static void ada_language_arch_info (struct gdbarch *,
235 struct language_arch_info *);
714e53ab 236
52ce6436
PH
237static struct value *ada_index_struct_field (int, struct value *, int,
238 struct type *);
239
240static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
241 struct expression *,
242 int *, enum noside);
52ce6436
PH
243
244static void aggregate_assign_from_choices (struct value *, struct value *,
245 struct expression *,
246 int *, LONGEST *, int *,
247 int, LONGEST, LONGEST);
248
249static void aggregate_assign_positional (struct value *, struct value *,
250 struct expression *,
251 int *, LONGEST *, int *, int,
252 LONGEST, LONGEST);
253
254
255static void aggregate_assign_others (struct value *, struct value *,
256 struct expression *,
257 int *, LONGEST *, int, LONGEST, LONGEST);
258
259
260static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
261
262
263static struct value *ada_evaluate_subexp (struct type *, struct expression *,
264 int *, enum noside);
265
266static void ada_forward_operator_length (struct expression *, int, int *,
267 int *);
852dff6c
JB
268
269static struct type *ada_find_any_type (const char *name);
b5ec771e
PA
270
271static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
272 (const lookup_name_info &lookup_name);
273
4c4b4cd2
PH
274\f
275
ee01b665
JB
276/* The result of a symbol lookup to be stored in our symbol cache. */
277
278struct cache_entry
279{
280 /* The name used to perform the lookup. */
281 const char *name;
282 /* The namespace used during the lookup. */
fe978cb0 283 domain_enum domain;
ee01b665
JB
284 /* The symbol returned by the lookup, or NULL if no matching symbol
285 was found. */
286 struct symbol *sym;
287 /* The block where the symbol was found, or NULL if no matching
288 symbol was found. */
289 const struct block *block;
290 /* A pointer to the next entry with the same hash. */
291 struct cache_entry *next;
292};
293
294/* The Ada symbol cache, used to store the result of Ada-mode symbol
295 lookups in the course of executing the user's commands.
296
297 The cache is implemented using a simple, fixed-sized hash.
298 The size is fixed on the grounds that there are not likely to be
299 all that many symbols looked up during any given session, regardless
300 of the size of the symbol table. If we decide to go to a resizable
301 table, let's just use the stuff from libiberty instead. */
302
303#define HASH_SIZE 1009
304
305struct ada_symbol_cache
306{
307 /* An obstack used to store the entries in our cache. */
308 struct obstack cache_space;
309
310 /* The root of the hash table used to implement our symbol cache. */
311 struct cache_entry *root[HASH_SIZE];
312};
313
314static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 315
4c4b4cd2 316/* Maximum-sized dynamic type. */
14f9c5c9
AS
317static unsigned int varsize_limit;
318
67cb5b2d 319static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
320#ifdef VMS
321 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
322#else
14f9c5c9 323 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 324#endif
14f9c5c9 325
4c4b4cd2 326/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 327static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 328 = "__gnat_ada_main_program_name";
14f9c5c9 329
4c4b4cd2
PH
330/* Limit on the number of warnings to raise per expression evaluation. */
331static int warning_limit = 2;
332
333/* Number of warning messages issued; reset to 0 by cleanups after
334 expression evaluation. */
335static int warnings_issued = 0;
336
337static const char *known_runtime_file_name_patterns[] = {
338 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
339};
340
341static const char *known_auxiliary_function_name_patterns[] = {
342 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
343};
344
c6044dd1
JB
345/* Maintenance-related settings for this module. */
346
347static struct cmd_list_element *maint_set_ada_cmdlist;
348static struct cmd_list_element *maint_show_ada_cmdlist;
349
350/* Implement the "maintenance set ada" (prefix) command. */
351
352static void
981a3fb3 353maint_set_ada_cmd (const char *args, int from_tty)
c6044dd1 354{
635c7e8a
TT
355 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
356 gdb_stdout);
c6044dd1
JB
357}
358
359/* Implement the "maintenance show ada" (prefix) command. */
360
361static void
981a3fb3 362maint_show_ada_cmd (const char *args, int from_tty)
c6044dd1
JB
363{
364 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
365}
366
367/* The "maintenance ada set/show ignore-descriptive-type" value. */
368
369static int ada_ignore_descriptive_types_p = 0;
370
e802dbe0
JB
371 /* Inferior-specific data. */
372
373/* Per-inferior data for this module. */
374
375struct ada_inferior_data
376{
377 /* The ada__tags__type_specific_data type, which is used when decoding
378 tagged types. With older versions of GNAT, this type was directly
379 accessible through a component ("tsd") in the object tag. But this
380 is no longer the case, so we cache it for each inferior. */
381 struct type *tsd_type;
3eecfa55
JB
382
383 /* The exception_support_info data. This data is used to determine
384 how to implement support for Ada exception catchpoints in a given
385 inferior. */
386 const struct exception_support_info *exception_info;
e802dbe0
JB
387};
388
389/* Our key to this module's inferior data. */
390static const struct inferior_data *ada_inferior_data;
391
392/* A cleanup routine for our inferior data. */
393static void
394ada_inferior_data_cleanup (struct inferior *inf, void *arg)
395{
396 struct ada_inferior_data *data;
397
9a3c8263 398 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
399 if (data != NULL)
400 xfree (data);
401}
402
403/* Return our inferior data for the given inferior (INF).
404
405 This function always returns a valid pointer to an allocated
406 ada_inferior_data structure. If INF's inferior data has not
407 been previously set, this functions creates a new one with all
408 fields set to zero, sets INF's inferior to it, and then returns
409 a pointer to that newly allocated ada_inferior_data. */
410
411static struct ada_inferior_data *
412get_ada_inferior_data (struct inferior *inf)
413{
414 struct ada_inferior_data *data;
415
9a3c8263 416 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
417 if (data == NULL)
418 {
41bf6aca 419 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
420 set_inferior_data (inf, ada_inferior_data, data);
421 }
422
423 return data;
424}
425
426/* Perform all necessary cleanups regarding our module's inferior data
427 that is required after the inferior INF just exited. */
428
429static void
430ada_inferior_exit (struct inferior *inf)
431{
432 ada_inferior_data_cleanup (inf, NULL);
433 set_inferior_data (inf, ada_inferior_data, NULL);
434}
435
ee01b665
JB
436
437 /* program-space-specific data. */
438
439/* This module's per-program-space data. */
440struct ada_pspace_data
441{
442 /* The Ada symbol cache. */
443 struct ada_symbol_cache *sym_cache;
444};
445
446/* Key to our per-program-space data. */
447static const struct program_space_data *ada_pspace_data_handle;
448
449/* Return this module's data for the given program space (PSPACE).
450 If not is found, add a zero'ed one now.
451
452 This function always returns a valid object. */
453
454static struct ada_pspace_data *
455get_ada_pspace_data (struct program_space *pspace)
456{
457 struct ada_pspace_data *data;
458
9a3c8263
SM
459 data = ((struct ada_pspace_data *)
460 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
461 if (data == NULL)
462 {
463 data = XCNEW (struct ada_pspace_data);
464 set_program_space_data (pspace, ada_pspace_data_handle, data);
465 }
466
467 return data;
468}
469
470/* The cleanup callback for this module's per-program-space data. */
471
472static void
473ada_pspace_data_cleanup (struct program_space *pspace, void *data)
474{
9a3c8263 475 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
476
477 if (pspace_data->sym_cache != NULL)
478 ada_free_symbol_cache (pspace_data->sym_cache);
479 xfree (pspace_data);
480}
481
4c4b4cd2
PH
482 /* Utilities */
483
720d1a40 484/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 485 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
486
487 Normally, we really expect a typedef type to only have 1 typedef layer.
488 In other words, we really expect the target type of a typedef type to be
489 a non-typedef type. This is particularly true for Ada units, because
490 the language does not have a typedef vs not-typedef distinction.
491 In that respect, the Ada compiler has been trying to eliminate as many
492 typedef definitions in the debugging information, since they generally
493 do not bring any extra information (we still use typedef under certain
494 circumstances related mostly to the GNAT encoding).
495
496 Unfortunately, we have seen situations where the debugging information
497 generated by the compiler leads to such multiple typedef layers. For
498 instance, consider the following example with stabs:
499
500 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
501 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
502
503 This is an error in the debugging information which causes type
504 pck__float_array___XUP to be defined twice, and the second time,
505 it is defined as a typedef of a typedef.
506
507 This is on the fringe of legality as far as debugging information is
508 concerned, and certainly unexpected. But it is easy to handle these
509 situations correctly, so we can afford to be lenient in this case. */
510
511static struct type *
512ada_typedef_target_type (struct type *type)
513{
514 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
515 type = TYPE_TARGET_TYPE (type);
516 return type;
517}
518
41d27058
JB
519/* Given DECODED_NAME a string holding a symbol name in its
520 decoded form (ie using the Ada dotted notation), returns
521 its unqualified name. */
522
523static const char *
524ada_unqualified_name (const char *decoded_name)
525{
2b0f535a
JB
526 const char *result;
527
528 /* If the decoded name starts with '<', it means that the encoded
529 name does not follow standard naming conventions, and thus that
530 it is not your typical Ada symbol name. Trying to unqualify it
531 is therefore pointless and possibly erroneous. */
532 if (decoded_name[0] == '<')
533 return decoded_name;
534
535 result = strrchr (decoded_name, '.');
41d27058
JB
536 if (result != NULL)
537 result++; /* Skip the dot... */
538 else
539 result = decoded_name;
540
541 return result;
542}
543
39e7af3e 544/* Return a string starting with '<', followed by STR, and '>'. */
41d27058 545
39e7af3e 546static std::string
41d27058
JB
547add_angle_brackets (const char *str)
548{
39e7af3e 549 return string_printf ("<%s>", str);
41d27058 550}
96d887e8 551
67cb5b2d 552static const char *
4c4b4cd2
PH
553ada_get_gdb_completer_word_break_characters (void)
554{
555 return ada_completer_word_break_characters;
556}
557
e79af960
JB
558/* Print an array element index using the Ada syntax. */
559
560static void
561ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 562 const struct value_print_options *options)
e79af960 563{
79a45b7d 564 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
565 fprintf_filtered (stream, " => ");
566}
567
f27cf670 568/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 569 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 570 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 571
f27cf670
AS
572void *
573grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 574{
d2e4a39e
AS
575 if (*size < min_size)
576 {
577 *size *= 2;
578 if (*size < min_size)
4c4b4cd2 579 *size = min_size;
f27cf670 580 vect = xrealloc (vect, *size * element_size);
d2e4a39e 581 }
f27cf670 582 return vect;
14f9c5c9
AS
583}
584
585/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 586 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
587
588static int
ebf56fd3 589field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
590{
591 int len = strlen (target);
5b4ee69b 592
d2e4a39e 593 return
4c4b4cd2
PH
594 (strncmp (field_name, target, len) == 0
595 && (field_name[len] == '\0'
61012eef 596 || (startswith (field_name + len, "___")
76a01679
JB
597 && strcmp (field_name + strlen (field_name) - 6,
598 "___XVN") != 0)));
14f9c5c9
AS
599}
600
601
872c8b51
JB
602/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
603 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
604 and return its index. This function also handles fields whose name
605 have ___ suffixes because the compiler sometimes alters their name
606 by adding such a suffix to represent fields with certain constraints.
607 If the field could not be found, return a negative number if
608 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
609
610int
611ada_get_field_index (const struct type *type, const char *field_name,
612 int maybe_missing)
613{
614 int fieldno;
872c8b51
JB
615 struct type *struct_type = check_typedef ((struct type *) type);
616
617 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
618 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
619 return fieldno;
620
621 if (!maybe_missing)
323e0a4a 622 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 623 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
624
625 return -1;
626}
627
628/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
629
630int
d2e4a39e 631ada_name_prefix_len (const char *name)
14f9c5c9
AS
632{
633 if (name == NULL)
634 return 0;
d2e4a39e 635 else
14f9c5c9 636 {
d2e4a39e 637 const char *p = strstr (name, "___");
5b4ee69b 638
14f9c5c9 639 if (p == NULL)
4c4b4cd2 640 return strlen (name);
14f9c5c9 641 else
4c4b4cd2 642 return p - name;
14f9c5c9
AS
643 }
644}
645
4c4b4cd2
PH
646/* Return non-zero if SUFFIX is a suffix of STR.
647 Return zero if STR is null. */
648
14f9c5c9 649static int
d2e4a39e 650is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
651{
652 int len1, len2;
5b4ee69b 653
14f9c5c9
AS
654 if (str == NULL)
655 return 0;
656 len1 = strlen (str);
657 len2 = strlen (suffix);
4c4b4cd2 658 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
659}
660
4c4b4cd2
PH
661/* The contents of value VAL, treated as a value of type TYPE. The
662 result is an lval in memory if VAL is. */
14f9c5c9 663
d2e4a39e 664static struct value *
4c4b4cd2 665coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 666{
61ee279c 667 type = ada_check_typedef (type);
df407dfe 668 if (value_type (val) == type)
4c4b4cd2 669 return val;
d2e4a39e 670 else
14f9c5c9 671 {
4c4b4cd2
PH
672 struct value *result;
673
674 /* Make sure that the object size is not unreasonable before
675 trying to allocate some memory for it. */
c1b5a1a6 676 ada_ensure_varsize_limit (type);
4c4b4cd2 677
41e8491f
JK
678 if (value_lazy (val)
679 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
680 result = allocate_value_lazy (type);
681 else
682 {
683 result = allocate_value (type);
9a0dc9e3 684 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 685 }
74bcbdf3 686 set_value_component_location (result, val);
9bbda503
AC
687 set_value_bitsize (result, value_bitsize (val));
688 set_value_bitpos (result, value_bitpos (val));
42ae5230 689 set_value_address (result, value_address (val));
14f9c5c9
AS
690 return result;
691 }
692}
693
fc1a4b47
AC
694static const gdb_byte *
695cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
696{
697 if (valaddr == NULL)
698 return NULL;
699 else
700 return valaddr + offset;
701}
702
703static CORE_ADDR
ebf56fd3 704cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
705{
706 if (address == 0)
707 return 0;
d2e4a39e 708 else
14f9c5c9
AS
709 return address + offset;
710}
711
4c4b4cd2
PH
712/* Issue a warning (as for the definition of warning in utils.c, but
713 with exactly one argument rather than ...), unless the limit on the
714 number of warnings has passed during the evaluation of the current
715 expression. */
a2249542 716
77109804
AC
717/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
718 provided by "complaint". */
a0b31db1 719static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 720
14f9c5c9 721static void
a2249542 722lim_warning (const char *format, ...)
14f9c5c9 723{
a2249542 724 va_list args;
a2249542 725
5b4ee69b 726 va_start (args, format);
4c4b4cd2
PH
727 warnings_issued += 1;
728 if (warnings_issued <= warning_limit)
a2249542
MK
729 vwarning (format, args);
730
731 va_end (args);
4c4b4cd2
PH
732}
733
714e53ab
PH
734/* Issue an error if the size of an object of type T is unreasonable,
735 i.e. if it would be a bad idea to allocate a value of this type in
736 GDB. */
737
c1b5a1a6
JB
738void
739ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
740{
741 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 742 error (_("object size is larger than varsize-limit"));
714e53ab
PH
743}
744
0963b4bd 745/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 746static LONGEST
c3e5cd34 747max_of_size (int size)
4c4b4cd2 748{
76a01679 749 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 750
76a01679 751 return top_bit | (top_bit - 1);
4c4b4cd2
PH
752}
753
0963b4bd 754/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 755static LONGEST
c3e5cd34 756min_of_size (int size)
4c4b4cd2 757{
c3e5cd34 758 return -max_of_size (size) - 1;
4c4b4cd2
PH
759}
760
0963b4bd 761/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 762static ULONGEST
c3e5cd34 763umax_of_size (int size)
4c4b4cd2 764{
76a01679 765 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 766
76a01679 767 return top_bit | (top_bit - 1);
4c4b4cd2
PH
768}
769
0963b4bd 770/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
771static LONGEST
772max_of_type (struct type *t)
4c4b4cd2 773{
c3e5cd34
PH
774 if (TYPE_UNSIGNED (t))
775 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
776 else
777 return max_of_size (TYPE_LENGTH (t));
778}
779
0963b4bd 780/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
781static LONGEST
782min_of_type (struct type *t)
783{
784 if (TYPE_UNSIGNED (t))
785 return 0;
786 else
787 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
788}
789
790/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
791LONGEST
792ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 793{
c3345124 794 type = resolve_dynamic_type (type, NULL, 0);
76a01679 795 switch (TYPE_CODE (type))
4c4b4cd2
PH
796 {
797 case TYPE_CODE_RANGE:
690cc4eb 798 return TYPE_HIGH_BOUND (type);
4c4b4cd2 799 case TYPE_CODE_ENUM:
14e75d8e 800 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
801 case TYPE_CODE_BOOL:
802 return 1;
803 case TYPE_CODE_CHAR:
76a01679 804 case TYPE_CODE_INT:
690cc4eb 805 return max_of_type (type);
4c4b4cd2 806 default:
43bbcdc2 807 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
808 }
809}
810
14e75d8e 811/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
812LONGEST
813ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 814{
c3345124 815 type = resolve_dynamic_type (type, NULL, 0);
76a01679 816 switch (TYPE_CODE (type))
4c4b4cd2
PH
817 {
818 case TYPE_CODE_RANGE:
690cc4eb 819 return TYPE_LOW_BOUND (type);
4c4b4cd2 820 case TYPE_CODE_ENUM:
14e75d8e 821 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
822 case TYPE_CODE_BOOL:
823 return 0;
824 case TYPE_CODE_CHAR:
76a01679 825 case TYPE_CODE_INT:
690cc4eb 826 return min_of_type (type);
4c4b4cd2 827 default:
43bbcdc2 828 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
829 }
830}
831
832/* The identity on non-range types. For range types, the underlying
76a01679 833 non-range scalar type. */
4c4b4cd2
PH
834
835static struct type *
18af8284 836get_base_type (struct type *type)
4c4b4cd2
PH
837{
838 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
839 {
76a01679
JB
840 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
841 return type;
4c4b4cd2
PH
842 type = TYPE_TARGET_TYPE (type);
843 }
844 return type;
14f9c5c9 845}
41246937
JB
846
847/* Return a decoded version of the given VALUE. This means returning
848 a value whose type is obtained by applying all the GNAT-specific
849 encondings, making the resulting type a static but standard description
850 of the initial type. */
851
852struct value *
853ada_get_decoded_value (struct value *value)
854{
855 struct type *type = ada_check_typedef (value_type (value));
856
857 if (ada_is_array_descriptor_type (type)
858 || (ada_is_constrained_packed_array_type (type)
859 && TYPE_CODE (type) != TYPE_CODE_PTR))
860 {
861 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
862 value = ada_coerce_to_simple_array_ptr (value);
863 else
864 value = ada_coerce_to_simple_array (value);
865 }
866 else
867 value = ada_to_fixed_value (value);
868
869 return value;
870}
871
872/* Same as ada_get_decoded_value, but with the given TYPE.
873 Because there is no associated actual value for this type,
874 the resulting type might be a best-effort approximation in
875 the case of dynamic types. */
876
877struct type *
878ada_get_decoded_type (struct type *type)
879{
880 type = to_static_fixed_type (type);
881 if (ada_is_constrained_packed_array_type (type))
882 type = ada_coerce_to_simple_array_type (type);
883 return type;
884}
885
4c4b4cd2 886\f
76a01679 887
4c4b4cd2 888 /* Language Selection */
14f9c5c9
AS
889
890/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 891 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 892
14f9c5c9 893enum language
ccefe4c4 894ada_update_initial_language (enum language lang)
14f9c5c9 895{
d2e4a39e 896 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 897 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 898 return language_ada;
14f9c5c9
AS
899
900 return lang;
901}
96d887e8
PH
902
903/* If the main procedure is written in Ada, then return its name.
904 The result is good until the next call. Return NULL if the main
905 procedure doesn't appear to be in Ada. */
906
907char *
908ada_main_name (void)
909{
3b7344d5 910 struct bound_minimal_symbol msym;
e83e4e24 911 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 912
96d887e8
PH
913 /* For Ada, the name of the main procedure is stored in a specific
914 string constant, generated by the binder. Look for that symbol,
915 extract its address, and then read that string. If we didn't find
916 that string, then most probably the main procedure is not written
917 in Ada. */
918 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
919
3b7344d5 920 if (msym.minsym != NULL)
96d887e8 921 {
f9bc20b9
JB
922 CORE_ADDR main_program_name_addr;
923 int err_code;
924
77e371c0 925 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 926 if (main_program_name_addr == 0)
323e0a4a 927 error (_("Invalid address for Ada main program name."));
96d887e8 928
f9bc20b9
JB
929 target_read_string (main_program_name_addr, &main_program_name,
930 1024, &err_code);
931
932 if (err_code != 0)
933 return NULL;
e83e4e24 934 return main_program_name.get ();
96d887e8
PH
935 }
936
937 /* The main procedure doesn't seem to be in Ada. */
938 return NULL;
939}
14f9c5c9 940\f
4c4b4cd2 941 /* Symbols */
d2e4a39e 942
4c4b4cd2
PH
943/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
944 of NULLs. */
14f9c5c9 945
d2e4a39e
AS
946const struct ada_opname_map ada_opname_table[] = {
947 {"Oadd", "\"+\"", BINOP_ADD},
948 {"Osubtract", "\"-\"", BINOP_SUB},
949 {"Omultiply", "\"*\"", BINOP_MUL},
950 {"Odivide", "\"/\"", BINOP_DIV},
951 {"Omod", "\"mod\"", BINOP_MOD},
952 {"Orem", "\"rem\"", BINOP_REM},
953 {"Oexpon", "\"**\"", BINOP_EXP},
954 {"Olt", "\"<\"", BINOP_LESS},
955 {"Ole", "\"<=\"", BINOP_LEQ},
956 {"Ogt", "\">\"", BINOP_GTR},
957 {"Oge", "\">=\"", BINOP_GEQ},
958 {"Oeq", "\"=\"", BINOP_EQUAL},
959 {"One", "\"/=\"", BINOP_NOTEQUAL},
960 {"Oand", "\"and\"", BINOP_BITWISE_AND},
961 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
962 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
963 {"Oconcat", "\"&\"", BINOP_CONCAT},
964 {"Oabs", "\"abs\"", UNOP_ABS},
965 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
966 {"Oadd", "\"+\"", UNOP_PLUS},
967 {"Osubtract", "\"-\"", UNOP_NEG},
968 {NULL, NULL}
14f9c5c9
AS
969};
970
b5ec771e
PA
971/* The "encoded" form of DECODED, according to GNAT conventions. The
972 result is valid until the next call to ada_encode. If
973 THROW_ERRORS, throw an error if invalid operator name is found.
974 Otherwise, return NULL in that case. */
4c4b4cd2 975
b5ec771e
PA
976static char *
977ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 978{
4c4b4cd2
PH
979 static char *encoding_buffer = NULL;
980 static size_t encoding_buffer_size = 0;
d2e4a39e 981 const char *p;
14f9c5c9 982 int k;
d2e4a39e 983
4c4b4cd2 984 if (decoded == NULL)
14f9c5c9
AS
985 return NULL;
986
4c4b4cd2
PH
987 GROW_VECT (encoding_buffer, encoding_buffer_size,
988 2 * strlen (decoded) + 10);
14f9c5c9
AS
989
990 k = 0;
4c4b4cd2 991 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 992 {
cdc7bb92 993 if (*p == '.')
4c4b4cd2
PH
994 {
995 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
996 k += 2;
997 }
14f9c5c9 998 else if (*p == '"')
4c4b4cd2
PH
999 {
1000 const struct ada_opname_map *mapping;
1001
1002 for (mapping = ada_opname_table;
1265e4aa 1003 mapping->encoded != NULL
61012eef 1004 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1005 ;
1006 if (mapping->encoded == NULL)
b5ec771e
PA
1007 {
1008 if (throw_errors)
1009 error (_("invalid Ada operator name: %s"), p);
1010 else
1011 return NULL;
1012 }
4c4b4cd2
PH
1013 strcpy (encoding_buffer + k, mapping->encoded);
1014 k += strlen (mapping->encoded);
1015 break;
1016 }
d2e4a39e 1017 else
4c4b4cd2
PH
1018 {
1019 encoding_buffer[k] = *p;
1020 k += 1;
1021 }
14f9c5c9
AS
1022 }
1023
4c4b4cd2
PH
1024 encoding_buffer[k] = '\0';
1025 return encoding_buffer;
14f9c5c9
AS
1026}
1027
b5ec771e
PA
1028/* The "encoded" form of DECODED, according to GNAT conventions.
1029 The result is valid until the next call to ada_encode. */
1030
1031char *
1032ada_encode (const char *decoded)
1033{
1034 return ada_encode_1 (decoded, true);
1035}
1036
14f9c5c9 1037/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1038 quotes, unfolded, but with the quotes stripped away. Result good
1039 to next call. */
1040
d2e4a39e
AS
1041char *
1042ada_fold_name (const char *name)
14f9c5c9 1043{
d2e4a39e 1044 static char *fold_buffer = NULL;
14f9c5c9
AS
1045 static size_t fold_buffer_size = 0;
1046
1047 int len = strlen (name);
d2e4a39e 1048 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1049
1050 if (name[0] == '\'')
1051 {
d2e4a39e
AS
1052 strncpy (fold_buffer, name + 1, len - 2);
1053 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1054 }
1055 else
1056 {
1057 int i;
5b4ee69b 1058
14f9c5c9 1059 for (i = 0; i <= len; i += 1)
4c4b4cd2 1060 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1061 }
1062
1063 return fold_buffer;
1064}
1065
529cad9c
PH
1066/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1067
1068static int
1069is_lower_alphanum (const char c)
1070{
1071 return (isdigit (c) || (isalpha (c) && islower (c)));
1072}
1073
c90092fe
JB
1074/* ENCODED is the linkage name of a symbol and LEN contains its length.
1075 This function saves in LEN the length of that same symbol name but
1076 without either of these suffixes:
29480c32
JB
1077 . .{DIGIT}+
1078 . ${DIGIT}+
1079 . ___{DIGIT}+
1080 . __{DIGIT}+.
c90092fe 1081
29480c32
JB
1082 These are suffixes introduced by the compiler for entities such as
1083 nested subprogram for instance, in order to avoid name clashes.
1084 They do not serve any purpose for the debugger. */
1085
1086static void
1087ada_remove_trailing_digits (const char *encoded, int *len)
1088{
1089 if (*len > 1 && isdigit (encoded[*len - 1]))
1090 {
1091 int i = *len - 2;
5b4ee69b 1092
29480c32
JB
1093 while (i > 0 && isdigit (encoded[i]))
1094 i--;
1095 if (i >= 0 && encoded[i] == '.')
1096 *len = i;
1097 else if (i >= 0 && encoded[i] == '$')
1098 *len = i;
61012eef 1099 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1100 *len = i - 2;
61012eef 1101 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1102 *len = i - 1;
1103 }
1104}
1105
1106/* Remove the suffix introduced by the compiler for protected object
1107 subprograms. */
1108
1109static void
1110ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1111{
1112 /* Remove trailing N. */
1113
1114 /* Protected entry subprograms are broken into two
1115 separate subprograms: The first one is unprotected, and has
1116 a 'N' suffix; the second is the protected version, and has
0963b4bd 1117 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1118 the protection. Since the P subprograms are internally generated,
1119 we leave these names undecoded, giving the user a clue that this
1120 entity is internal. */
1121
1122 if (*len > 1
1123 && encoded[*len - 1] == 'N'
1124 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1125 *len = *len - 1;
1126}
1127
69fadcdf
JB
1128/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1129
1130static void
1131ada_remove_Xbn_suffix (const char *encoded, int *len)
1132{
1133 int i = *len - 1;
1134
1135 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1136 i--;
1137
1138 if (encoded[i] != 'X')
1139 return;
1140
1141 if (i == 0)
1142 return;
1143
1144 if (isalnum (encoded[i-1]))
1145 *len = i;
1146}
1147
29480c32
JB
1148/* If ENCODED follows the GNAT entity encoding conventions, then return
1149 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1150 replaced by ENCODED.
14f9c5c9 1151
4c4b4cd2 1152 The resulting string is valid until the next call of ada_decode.
29480c32 1153 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1154 is returned. */
1155
1156const char *
1157ada_decode (const char *encoded)
14f9c5c9
AS
1158{
1159 int i, j;
1160 int len0;
d2e4a39e 1161 const char *p;
4c4b4cd2 1162 char *decoded;
14f9c5c9 1163 int at_start_name;
4c4b4cd2
PH
1164 static char *decoding_buffer = NULL;
1165 static size_t decoding_buffer_size = 0;
d2e4a39e 1166
29480c32
JB
1167 /* The name of the Ada main procedure starts with "_ada_".
1168 This prefix is not part of the decoded name, so skip this part
1169 if we see this prefix. */
61012eef 1170 if (startswith (encoded, "_ada_"))
4c4b4cd2 1171 encoded += 5;
14f9c5c9 1172
29480c32
JB
1173 /* If the name starts with '_', then it is not a properly encoded
1174 name, so do not attempt to decode it. Similarly, if the name
1175 starts with '<', the name should not be decoded. */
4c4b4cd2 1176 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1177 goto Suppress;
1178
4c4b4cd2 1179 len0 = strlen (encoded);
4c4b4cd2 1180
29480c32
JB
1181 ada_remove_trailing_digits (encoded, &len0);
1182 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1183
4c4b4cd2
PH
1184 /* Remove the ___X.* suffix if present. Do not forget to verify that
1185 the suffix is located before the current "end" of ENCODED. We want
1186 to avoid re-matching parts of ENCODED that have previously been
1187 marked as discarded (by decrementing LEN0). */
1188 p = strstr (encoded, "___");
1189 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1190 {
1191 if (p[3] == 'X')
4c4b4cd2 1192 len0 = p - encoded;
14f9c5c9 1193 else
4c4b4cd2 1194 goto Suppress;
14f9c5c9 1195 }
4c4b4cd2 1196
29480c32
JB
1197 /* Remove any trailing TKB suffix. It tells us that this symbol
1198 is for the body of a task, but that information does not actually
1199 appear in the decoded name. */
1200
61012eef 1201 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1202 len0 -= 3;
76a01679 1203
a10967fa
JB
1204 /* Remove any trailing TB suffix. The TB suffix is slightly different
1205 from the TKB suffix because it is used for non-anonymous task
1206 bodies. */
1207
61012eef 1208 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1209 len0 -= 2;
1210
29480c32
JB
1211 /* Remove trailing "B" suffixes. */
1212 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1213
61012eef 1214 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1215 len0 -= 1;
1216
4c4b4cd2 1217 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1218
4c4b4cd2
PH
1219 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1220 decoded = decoding_buffer;
14f9c5c9 1221
29480c32
JB
1222 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1223
4c4b4cd2 1224 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1225 {
4c4b4cd2
PH
1226 i = len0 - 2;
1227 while ((i >= 0 && isdigit (encoded[i]))
1228 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1229 i -= 1;
1230 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1231 len0 = i - 1;
1232 else if (encoded[i] == '$')
1233 len0 = i;
d2e4a39e 1234 }
14f9c5c9 1235
29480c32
JB
1236 /* The first few characters that are not alphabetic are not part
1237 of any encoding we use, so we can copy them over verbatim. */
1238
4c4b4cd2
PH
1239 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1240 decoded[j] = encoded[i];
14f9c5c9
AS
1241
1242 at_start_name = 1;
1243 while (i < len0)
1244 {
29480c32 1245 /* Is this a symbol function? */
4c4b4cd2
PH
1246 if (at_start_name && encoded[i] == 'O')
1247 {
1248 int k;
5b4ee69b 1249
4c4b4cd2
PH
1250 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1251 {
1252 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1253 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1254 op_len - 1) == 0)
1255 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1256 {
1257 strcpy (decoded + j, ada_opname_table[k].decoded);
1258 at_start_name = 0;
1259 i += op_len;
1260 j += strlen (ada_opname_table[k].decoded);
1261 break;
1262 }
1263 }
1264 if (ada_opname_table[k].encoded != NULL)
1265 continue;
1266 }
14f9c5c9
AS
1267 at_start_name = 0;
1268
529cad9c
PH
1269 /* Replace "TK__" with "__", which will eventually be translated
1270 into "." (just below). */
1271
61012eef 1272 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1273 i += 2;
529cad9c 1274
29480c32
JB
1275 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1276 be translated into "." (just below). These are internal names
1277 generated for anonymous blocks inside which our symbol is nested. */
1278
1279 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1280 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1281 && isdigit (encoded [i+4]))
1282 {
1283 int k = i + 5;
1284
1285 while (k < len0 && isdigit (encoded[k]))
1286 k++; /* Skip any extra digit. */
1287
1288 /* Double-check that the "__B_{DIGITS}+" sequence we found
1289 is indeed followed by "__". */
1290 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1291 i = k;
1292 }
1293
529cad9c
PH
1294 /* Remove _E{DIGITS}+[sb] */
1295
1296 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1297 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1298 one implements the actual entry code, and has a suffix following
1299 the convention above; the second one implements the barrier and
1300 uses the same convention as above, except that the 'E' is replaced
1301 by a 'B'.
1302
1303 Just as above, we do not decode the name of barrier functions
1304 to give the user a clue that the code he is debugging has been
1305 internally generated. */
1306
1307 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1308 && isdigit (encoded[i+2]))
1309 {
1310 int k = i + 3;
1311
1312 while (k < len0 && isdigit (encoded[k]))
1313 k++;
1314
1315 if (k < len0
1316 && (encoded[k] == 'b' || encoded[k] == 's'))
1317 {
1318 k++;
1319 /* Just as an extra precaution, make sure that if this
1320 suffix is followed by anything else, it is a '_'.
1321 Otherwise, we matched this sequence by accident. */
1322 if (k == len0
1323 || (k < len0 && encoded[k] == '_'))
1324 i = k;
1325 }
1326 }
1327
1328 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1329 the GNAT front-end in protected object subprograms. */
1330
1331 if (i < len0 + 3
1332 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1333 {
1334 /* Backtrack a bit up until we reach either the begining of
1335 the encoded name, or "__". Make sure that we only find
1336 digits or lowercase characters. */
1337 const char *ptr = encoded + i - 1;
1338
1339 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1340 ptr--;
1341 if (ptr < encoded
1342 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1343 i++;
1344 }
1345
4c4b4cd2
PH
1346 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1347 {
29480c32
JB
1348 /* This is a X[bn]* sequence not separated from the previous
1349 part of the name with a non-alpha-numeric character (in other
1350 words, immediately following an alpha-numeric character), then
1351 verify that it is placed at the end of the encoded name. If
1352 not, then the encoding is not valid and we should abort the
1353 decoding. Otherwise, just skip it, it is used in body-nested
1354 package names. */
4c4b4cd2
PH
1355 do
1356 i += 1;
1357 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1358 if (i < len0)
1359 goto Suppress;
1360 }
cdc7bb92 1361 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1362 {
29480c32 1363 /* Replace '__' by '.'. */
4c4b4cd2
PH
1364 decoded[j] = '.';
1365 at_start_name = 1;
1366 i += 2;
1367 j += 1;
1368 }
14f9c5c9 1369 else
4c4b4cd2 1370 {
29480c32
JB
1371 /* It's a character part of the decoded name, so just copy it
1372 over. */
4c4b4cd2
PH
1373 decoded[j] = encoded[i];
1374 i += 1;
1375 j += 1;
1376 }
14f9c5c9 1377 }
4c4b4cd2 1378 decoded[j] = '\000';
14f9c5c9 1379
29480c32
JB
1380 /* Decoded names should never contain any uppercase character.
1381 Double-check this, and abort the decoding if we find one. */
1382
4c4b4cd2
PH
1383 for (i = 0; decoded[i] != '\0'; i += 1)
1384 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1385 goto Suppress;
1386
4c4b4cd2
PH
1387 if (strcmp (decoded, encoded) == 0)
1388 return encoded;
1389 else
1390 return decoded;
14f9c5c9
AS
1391
1392Suppress:
4c4b4cd2
PH
1393 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1394 decoded = decoding_buffer;
1395 if (encoded[0] == '<')
1396 strcpy (decoded, encoded);
14f9c5c9 1397 else
88c15c34 1398 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1399 return decoded;
1400
1401}
1402
1403/* Table for keeping permanent unique copies of decoded names. Once
1404 allocated, names in this table are never released. While this is a
1405 storage leak, it should not be significant unless there are massive
1406 changes in the set of decoded names in successive versions of a
1407 symbol table loaded during a single session. */
1408static struct htab *decoded_names_store;
1409
1410/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1411 in the language-specific part of GSYMBOL, if it has not been
1412 previously computed. Tries to save the decoded name in the same
1413 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1414 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1415 GSYMBOL).
4c4b4cd2
PH
1416 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1417 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1418 when a decoded name is cached in it. */
4c4b4cd2 1419
45e6c716 1420const char *
f85f34ed 1421ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1422{
f85f34ed
TT
1423 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1424 const char **resultp =
615b3f62 1425 &gsymbol->language_specific.demangled_name;
5b4ee69b 1426
f85f34ed 1427 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1428 {
1429 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1430 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1431
f85f34ed 1432 gsymbol->ada_mangled = 1;
5b4ee69b 1433
f85f34ed 1434 if (obstack != NULL)
224c3ddb
SM
1435 *resultp
1436 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1437 else
76a01679 1438 {
f85f34ed
TT
1439 /* Sometimes, we can't find a corresponding objfile, in
1440 which case, we put the result on the heap. Since we only
1441 decode when needed, we hope this usually does not cause a
1442 significant memory leak (FIXME). */
1443
76a01679
JB
1444 char **slot = (char **) htab_find_slot (decoded_names_store,
1445 decoded, INSERT);
5b4ee69b 1446
76a01679
JB
1447 if (*slot == NULL)
1448 *slot = xstrdup (decoded);
1449 *resultp = *slot;
1450 }
4c4b4cd2 1451 }
14f9c5c9 1452
4c4b4cd2
PH
1453 return *resultp;
1454}
76a01679 1455
2c0b251b 1456static char *
76a01679 1457ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1458{
1459 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1460}
1461
8b302db8
TT
1462/* Implement la_sniff_from_mangled_name for Ada. */
1463
1464static int
1465ada_sniff_from_mangled_name (const char *mangled, char **out)
1466{
1467 const char *demangled = ada_decode (mangled);
1468
1469 *out = NULL;
1470
1471 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1472 {
1473 /* Set the gsymbol language to Ada, but still return 0.
1474 Two reasons for that:
1475
1476 1. For Ada, we prefer computing the symbol's decoded name
1477 on the fly rather than pre-compute it, in order to save
1478 memory (Ada projects are typically very large).
1479
1480 2. There are some areas in the definition of the GNAT
1481 encoding where, with a bit of bad luck, we might be able
1482 to decode a non-Ada symbol, generating an incorrect
1483 demangled name (Eg: names ending with "TB" for instance
1484 are identified as task bodies and so stripped from
1485 the decoded name returned).
1486
1487 Returning 1, here, but not setting *DEMANGLED, helps us get a
1488 little bit of the best of both worlds. Because we're last,
1489 we should not affect any of the other languages that were
1490 able to demangle the symbol before us; we get to correctly
1491 tag Ada symbols as such; and even if we incorrectly tagged a
1492 non-Ada symbol, which should be rare, any routing through the
1493 Ada language should be transparent (Ada tries to behave much
1494 like C/C++ with non-Ada symbols). */
1495 return 1;
1496 }
1497
1498 return 0;
1499}
1500
14f9c5c9 1501\f
d2e4a39e 1502
4c4b4cd2 1503 /* Arrays */
14f9c5c9 1504
28c85d6c
JB
1505/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1506 generated by the GNAT compiler to describe the index type used
1507 for each dimension of an array, check whether it follows the latest
1508 known encoding. If not, fix it up to conform to the latest encoding.
1509 Otherwise, do nothing. This function also does nothing if
1510 INDEX_DESC_TYPE is NULL.
1511
1512 The GNAT encoding used to describle the array index type evolved a bit.
1513 Initially, the information would be provided through the name of each
1514 field of the structure type only, while the type of these fields was
1515 described as unspecified and irrelevant. The debugger was then expected
1516 to perform a global type lookup using the name of that field in order
1517 to get access to the full index type description. Because these global
1518 lookups can be very expensive, the encoding was later enhanced to make
1519 the global lookup unnecessary by defining the field type as being
1520 the full index type description.
1521
1522 The purpose of this routine is to allow us to support older versions
1523 of the compiler by detecting the use of the older encoding, and by
1524 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1525 we essentially replace each field's meaningless type by the associated
1526 index subtype). */
1527
1528void
1529ada_fixup_array_indexes_type (struct type *index_desc_type)
1530{
1531 int i;
1532
1533 if (index_desc_type == NULL)
1534 return;
1535 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1536
1537 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1538 to check one field only, no need to check them all). If not, return
1539 now.
1540
1541 If our INDEX_DESC_TYPE was generated using the older encoding,
1542 the field type should be a meaningless integer type whose name
1543 is not equal to the field name. */
1544 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1545 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1546 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1547 return;
1548
1549 /* Fixup each field of INDEX_DESC_TYPE. */
1550 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1551 {
0d5cff50 1552 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1553 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1554
1555 if (raw_type)
1556 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1557 }
1558}
1559
4c4b4cd2 1560/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1561
a121b7c1 1562static const char *bound_name[] = {
d2e4a39e 1563 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1564 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1565};
1566
1567/* Maximum number of array dimensions we are prepared to handle. */
1568
4c4b4cd2 1569#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1570
14f9c5c9 1571
4c4b4cd2
PH
1572/* The desc_* routines return primitive portions of array descriptors
1573 (fat pointers). */
14f9c5c9
AS
1574
1575/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1576 level of indirection, if needed. */
1577
d2e4a39e
AS
1578static struct type *
1579desc_base_type (struct type *type)
14f9c5c9
AS
1580{
1581 if (type == NULL)
1582 return NULL;
61ee279c 1583 type = ada_check_typedef (type);
720d1a40
JB
1584 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1585 type = ada_typedef_target_type (type);
1586
1265e4aa
JB
1587 if (type != NULL
1588 && (TYPE_CODE (type) == TYPE_CODE_PTR
1589 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1590 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1591 else
1592 return type;
1593}
1594
4c4b4cd2
PH
1595/* True iff TYPE indicates a "thin" array pointer type. */
1596
14f9c5c9 1597static int
d2e4a39e 1598is_thin_pntr (struct type *type)
14f9c5c9 1599{
d2e4a39e 1600 return
14f9c5c9
AS
1601 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1602 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1603}
1604
4c4b4cd2
PH
1605/* The descriptor type for thin pointer type TYPE. */
1606
d2e4a39e
AS
1607static struct type *
1608thin_descriptor_type (struct type *type)
14f9c5c9 1609{
d2e4a39e 1610 struct type *base_type = desc_base_type (type);
5b4ee69b 1611
14f9c5c9
AS
1612 if (base_type == NULL)
1613 return NULL;
1614 if (is_suffix (ada_type_name (base_type), "___XVE"))
1615 return base_type;
d2e4a39e 1616 else
14f9c5c9 1617 {
d2e4a39e 1618 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1619
14f9c5c9 1620 if (alt_type == NULL)
4c4b4cd2 1621 return base_type;
14f9c5c9 1622 else
4c4b4cd2 1623 return alt_type;
14f9c5c9
AS
1624 }
1625}
1626
4c4b4cd2
PH
1627/* A pointer to the array data for thin-pointer value VAL. */
1628
d2e4a39e
AS
1629static struct value *
1630thin_data_pntr (struct value *val)
14f9c5c9 1631{
828292f2 1632 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1633 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1634
556bdfd4
UW
1635 data_type = lookup_pointer_type (data_type);
1636
14f9c5c9 1637 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1638 return value_cast (data_type, value_copy (val));
d2e4a39e 1639 else
42ae5230 1640 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1641}
1642
4c4b4cd2
PH
1643/* True iff TYPE indicates a "thick" array pointer type. */
1644
14f9c5c9 1645static int
d2e4a39e 1646is_thick_pntr (struct type *type)
14f9c5c9
AS
1647{
1648 type = desc_base_type (type);
1649 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1650 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1651}
1652
4c4b4cd2
PH
1653/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1654 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1655
d2e4a39e
AS
1656static struct type *
1657desc_bounds_type (struct type *type)
14f9c5c9 1658{
d2e4a39e 1659 struct type *r;
14f9c5c9
AS
1660
1661 type = desc_base_type (type);
1662
1663 if (type == NULL)
1664 return NULL;
1665 else if (is_thin_pntr (type))
1666 {
1667 type = thin_descriptor_type (type);
1668 if (type == NULL)
4c4b4cd2 1669 return NULL;
14f9c5c9
AS
1670 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1671 if (r != NULL)
61ee279c 1672 return ada_check_typedef (r);
14f9c5c9
AS
1673 }
1674 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1675 {
1676 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1677 if (r != NULL)
61ee279c 1678 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1679 }
1680 return NULL;
1681}
1682
1683/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1684 one, a pointer to its bounds data. Otherwise NULL. */
1685
d2e4a39e
AS
1686static struct value *
1687desc_bounds (struct value *arr)
14f9c5c9 1688{
df407dfe 1689 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1690
d2e4a39e 1691 if (is_thin_pntr (type))
14f9c5c9 1692 {
d2e4a39e 1693 struct type *bounds_type =
4c4b4cd2 1694 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1695 LONGEST addr;
1696
4cdfadb1 1697 if (bounds_type == NULL)
323e0a4a 1698 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1699
1700 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1701 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1702 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1703 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1704 addr = value_as_long (arr);
d2e4a39e 1705 else
42ae5230 1706 addr = value_address (arr);
14f9c5c9 1707
d2e4a39e 1708 return
4c4b4cd2
PH
1709 value_from_longest (lookup_pointer_type (bounds_type),
1710 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1711 }
1712
1713 else if (is_thick_pntr (type))
05e522ef
JB
1714 {
1715 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1716 _("Bad GNAT array descriptor"));
1717 struct type *p_bounds_type = value_type (p_bounds);
1718
1719 if (p_bounds_type
1720 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1721 {
1722 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1723
1724 if (TYPE_STUB (target_type))
1725 p_bounds = value_cast (lookup_pointer_type
1726 (ada_check_typedef (target_type)),
1727 p_bounds);
1728 }
1729 else
1730 error (_("Bad GNAT array descriptor"));
1731
1732 return p_bounds;
1733 }
14f9c5c9
AS
1734 else
1735 return NULL;
1736}
1737
4c4b4cd2
PH
1738/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1739 position of the field containing the address of the bounds data. */
1740
14f9c5c9 1741static int
d2e4a39e 1742fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1743{
1744 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1745}
1746
1747/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1748 size of the field containing the address of the bounds data. */
1749
14f9c5c9 1750static int
d2e4a39e 1751fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1752{
1753 type = desc_base_type (type);
1754
d2e4a39e 1755 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1756 return TYPE_FIELD_BITSIZE (type, 1);
1757 else
61ee279c 1758 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1759}
1760
4c4b4cd2 1761/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1762 pointer to one, the type of its array data (a array-with-no-bounds type);
1763 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1764 data. */
4c4b4cd2 1765
d2e4a39e 1766static struct type *
556bdfd4 1767desc_data_target_type (struct type *type)
14f9c5c9
AS
1768{
1769 type = desc_base_type (type);
1770
4c4b4cd2 1771 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1772 if (is_thin_pntr (type))
556bdfd4 1773 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1774 else if (is_thick_pntr (type))
556bdfd4
UW
1775 {
1776 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1777
1778 if (data_type
1779 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1780 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1781 }
1782
1783 return NULL;
14f9c5c9
AS
1784}
1785
1786/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1787 its array data. */
4c4b4cd2 1788
d2e4a39e
AS
1789static struct value *
1790desc_data (struct value *arr)
14f9c5c9 1791{
df407dfe 1792 struct type *type = value_type (arr);
5b4ee69b 1793
14f9c5c9
AS
1794 if (is_thin_pntr (type))
1795 return thin_data_pntr (arr);
1796 else if (is_thick_pntr (type))
d2e4a39e 1797 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1798 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1799 else
1800 return NULL;
1801}
1802
1803
1804/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1805 position of the field containing the address of the data. */
1806
14f9c5c9 1807static int
d2e4a39e 1808fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1809{
1810 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1811}
1812
1813/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1814 size of the field containing the address of the data. */
1815
14f9c5c9 1816static int
d2e4a39e 1817fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1818{
1819 type = desc_base_type (type);
1820
1821 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1822 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1823 else
14f9c5c9
AS
1824 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1825}
1826
4c4b4cd2 1827/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1828 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1829 bound, if WHICH is 1. The first bound is I=1. */
1830
d2e4a39e
AS
1831static struct value *
1832desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1833{
d2e4a39e 1834 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1835 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1836}
1837
1838/* If BOUNDS is an array-bounds structure type, return the bit position
1839 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1840 bound, if WHICH is 1. The first bound is I=1. */
1841
14f9c5c9 1842static int
d2e4a39e 1843desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1844{
d2e4a39e 1845 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1846}
1847
1848/* If BOUNDS is an array-bounds structure type, return the bit field size
1849 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1850 bound, if WHICH is 1. The first bound is I=1. */
1851
76a01679 1852static int
d2e4a39e 1853desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1854{
1855 type = desc_base_type (type);
1856
d2e4a39e
AS
1857 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1858 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1859 else
1860 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1861}
1862
1863/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1864 Ith bound (numbering from 1). Otherwise, NULL. */
1865
d2e4a39e
AS
1866static struct type *
1867desc_index_type (struct type *type, int i)
14f9c5c9
AS
1868{
1869 type = desc_base_type (type);
1870
1871 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1872 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1873 else
14f9c5c9
AS
1874 return NULL;
1875}
1876
4c4b4cd2
PH
1877/* The number of index positions in the array-bounds type TYPE.
1878 Return 0 if TYPE is NULL. */
1879
14f9c5c9 1880static int
d2e4a39e 1881desc_arity (struct type *type)
14f9c5c9
AS
1882{
1883 type = desc_base_type (type);
1884
1885 if (type != NULL)
1886 return TYPE_NFIELDS (type) / 2;
1887 return 0;
1888}
1889
4c4b4cd2
PH
1890/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1891 an array descriptor type (representing an unconstrained array
1892 type). */
1893
76a01679
JB
1894static int
1895ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1896{
1897 if (type == NULL)
1898 return 0;
61ee279c 1899 type = ada_check_typedef (type);
4c4b4cd2 1900 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1901 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1902}
1903
52ce6436 1904/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1905 * to one. */
52ce6436 1906
2c0b251b 1907static int
52ce6436
PH
1908ada_is_array_type (struct type *type)
1909{
1910 while (type != NULL
1911 && (TYPE_CODE (type) == TYPE_CODE_PTR
1912 || TYPE_CODE (type) == TYPE_CODE_REF))
1913 type = TYPE_TARGET_TYPE (type);
1914 return ada_is_direct_array_type (type);
1915}
1916
4c4b4cd2 1917/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1918
14f9c5c9 1919int
4c4b4cd2 1920ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1921{
1922 if (type == NULL)
1923 return 0;
61ee279c 1924 type = ada_check_typedef (type);
14f9c5c9 1925 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1926 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1927 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1928 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1929}
1930
4c4b4cd2
PH
1931/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1932
14f9c5c9 1933int
4c4b4cd2 1934ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1935{
556bdfd4 1936 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1937
1938 if (type == NULL)
1939 return 0;
61ee279c 1940 type = ada_check_typedef (type);
556bdfd4
UW
1941 return (data_type != NULL
1942 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1943 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1944}
1945
1946/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1947 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1948 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1949 is still needed. */
1950
14f9c5c9 1951int
ebf56fd3 1952ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1953{
d2e4a39e 1954 return
14f9c5c9
AS
1955 type != NULL
1956 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1957 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1958 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1959 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1960}
1961
1962
4c4b4cd2 1963/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1964 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1965 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1966 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1967 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1968 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1969 a descriptor. */
d2e4a39e
AS
1970struct type *
1971ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1972{
ad82864c
JB
1973 if (ada_is_constrained_packed_array_type (value_type (arr)))
1974 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1975
df407dfe
AC
1976 if (!ada_is_array_descriptor_type (value_type (arr)))
1977 return value_type (arr);
d2e4a39e
AS
1978
1979 if (!bounds)
ad82864c
JB
1980 {
1981 struct type *array_type =
1982 ada_check_typedef (desc_data_target_type (value_type (arr)));
1983
1984 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1985 TYPE_FIELD_BITSIZE (array_type, 0) =
1986 decode_packed_array_bitsize (value_type (arr));
1987
1988 return array_type;
1989 }
14f9c5c9
AS
1990 else
1991 {
d2e4a39e 1992 struct type *elt_type;
14f9c5c9 1993 int arity;
d2e4a39e 1994 struct value *descriptor;
14f9c5c9 1995
df407dfe
AC
1996 elt_type = ada_array_element_type (value_type (arr), -1);
1997 arity = ada_array_arity (value_type (arr));
14f9c5c9 1998
d2e4a39e 1999 if (elt_type == NULL || arity == 0)
df407dfe 2000 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2001
2002 descriptor = desc_bounds (arr);
d2e4a39e 2003 if (value_as_long (descriptor) == 0)
4c4b4cd2 2004 return NULL;
d2e4a39e 2005 while (arity > 0)
4c4b4cd2 2006 {
e9bb382b
UW
2007 struct type *range_type = alloc_type_copy (value_type (arr));
2008 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2009 struct value *low = desc_one_bound (descriptor, arity, 0);
2010 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2011
5b4ee69b 2012 arity -= 1;
0c9c3474
SA
2013 create_static_range_type (range_type, value_type (low),
2014 longest_to_int (value_as_long (low)),
2015 longest_to_int (value_as_long (high)));
4c4b4cd2 2016 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2017
2018 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2019 {
2020 /* We need to store the element packed bitsize, as well as
2021 recompute the array size, because it was previously
2022 computed based on the unpacked element size. */
2023 LONGEST lo = value_as_long (low);
2024 LONGEST hi = value_as_long (high);
2025
2026 TYPE_FIELD_BITSIZE (elt_type, 0) =
2027 decode_packed_array_bitsize (value_type (arr));
2028 /* If the array has no element, then the size is already
2029 zero, and does not need to be recomputed. */
2030 if (lo < hi)
2031 {
2032 int array_bitsize =
2033 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2034
2035 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2036 }
2037 }
4c4b4cd2 2038 }
14f9c5c9
AS
2039
2040 return lookup_pointer_type (elt_type);
2041 }
2042}
2043
2044/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2045 Otherwise, returns either a standard GDB array with bounds set
2046 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2047 GDB array. Returns NULL if ARR is a null fat pointer. */
2048
d2e4a39e
AS
2049struct value *
2050ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2051{
df407dfe 2052 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2053 {
d2e4a39e 2054 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2055
14f9c5c9 2056 if (arrType == NULL)
4c4b4cd2 2057 return NULL;
14f9c5c9
AS
2058 return value_cast (arrType, value_copy (desc_data (arr)));
2059 }
ad82864c
JB
2060 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2061 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2062 else
2063 return arr;
2064}
2065
2066/* If ARR does not represent an array, returns ARR unchanged.
2067 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2068 be ARR itself if it already is in the proper form). */
2069
720d1a40 2070struct value *
d2e4a39e 2071ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2072{
df407dfe 2073 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2074 {
d2e4a39e 2075 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2076
14f9c5c9 2077 if (arrVal == NULL)
323e0a4a 2078 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2079 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2080 return value_ind (arrVal);
2081 }
ad82864c
JB
2082 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2083 return decode_constrained_packed_array (arr);
d2e4a39e 2084 else
14f9c5c9
AS
2085 return arr;
2086}
2087
2088/* If TYPE represents a GNAT array type, return it translated to an
2089 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2090 packing). For other types, is the identity. */
2091
d2e4a39e
AS
2092struct type *
2093ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2094{
ad82864c
JB
2095 if (ada_is_constrained_packed_array_type (type))
2096 return decode_constrained_packed_array_type (type);
17280b9f
UW
2097
2098 if (ada_is_array_descriptor_type (type))
556bdfd4 2099 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2100
2101 return type;
14f9c5c9
AS
2102}
2103
4c4b4cd2
PH
2104/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2105
ad82864c
JB
2106static int
2107ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2108{
2109 if (type == NULL)
2110 return 0;
4c4b4cd2 2111 type = desc_base_type (type);
61ee279c 2112 type = ada_check_typedef (type);
d2e4a39e 2113 return
14f9c5c9
AS
2114 ada_type_name (type) != NULL
2115 && strstr (ada_type_name (type), "___XP") != NULL;
2116}
2117
ad82864c
JB
2118/* Non-zero iff TYPE represents a standard GNAT constrained
2119 packed-array type. */
2120
2121int
2122ada_is_constrained_packed_array_type (struct type *type)
2123{
2124 return ada_is_packed_array_type (type)
2125 && !ada_is_array_descriptor_type (type);
2126}
2127
2128/* Non-zero iff TYPE represents an array descriptor for a
2129 unconstrained packed-array type. */
2130
2131static int
2132ada_is_unconstrained_packed_array_type (struct type *type)
2133{
2134 return ada_is_packed_array_type (type)
2135 && ada_is_array_descriptor_type (type);
2136}
2137
2138/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2139 return the size of its elements in bits. */
2140
2141static long
2142decode_packed_array_bitsize (struct type *type)
2143{
0d5cff50
DE
2144 const char *raw_name;
2145 const char *tail;
ad82864c
JB
2146 long bits;
2147
720d1a40
JB
2148 /* Access to arrays implemented as fat pointers are encoded as a typedef
2149 of the fat pointer type. We need the name of the fat pointer type
2150 to do the decoding, so strip the typedef layer. */
2151 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2152 type = ada_typedef_target_type (type);
2153
2154 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2155 if (!raw_name)
2156 raw_name = ada_type_name (desc_base_type (type));
2157
2158 if (!raw_name)
2159 return 0;
2160
2161 tail = strstr (raw_name, "___XP");
720d1a40 2162 gdb_assert (tail != NULL);
ad82864c
JB
2163
2164 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2165 {
2166 lim_warning
2167 (_("could not understand bit size information on packed array"));
2168 return 0;
2169 }
2170
2171 return bits;
2172}
2173
14f9c5c9
AS
2174/* Given that TYPE is a standard GDB array type with all bounds filled
2175 in, and that the element size of its ultimate scalar constituents
2176 (that is, either its elements, or, if it is an array of arrays, its
2177 elements' elements, etc.) is *ELT_BITS, return an identical type,
2178 but with the bit sizes of its elements (and those of any
2179 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2180 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2181 in bits.
2182
2183 Note that, for arrays whose index type has an XA encoding where
2184 a bound references a record discriminant, getting that discriminant,
2185 and therefore the actual value of that bound, is not possible
2186 because none of the given parameters gives us access to the record.
2187 This function assumes that it is OK in the context where it is being
2188 used to return an array whose bounds are still dynamic and where
2189 the length is arbitrary. */
4c4b4cd2 2190
d2e4a39e 2191static struct type *
ad82864c 2192constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2193{
d2e4a39e
AS
2194 struct type *new_elt_type;
2195 struct type *new_type;
99b1c762
JB
2196 struct type *index_type_desc;
2197 struct type *index_type;
14f9c5c9
AS
2198 LONGEST low_bound, high_bound;
2199
61ee279c 2200 type = ada_check_typedef (type);
14f9c5c9
AS
2201 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2202 return type;
2203
99b1c762
JB
2204 index_type_desc = ada_find_parallel_type (type, "___XA");
2205 if (index_type_desc)
2206 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2207 NULL);
2208 else
2209 index_type = TYPE_INDEX_TYPE (type);
2210
e9bb382b 2211 new_type = alloc_type_copy (type);
ad82864c
JB
2212 new_elt_type =
2213 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2214 elt_bits);
99b1c762 2215 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2216 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2217 TYPE_NAME (new_type) = ada_type_name (type);
2218
4a46959e
JB
2219 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2220 && is_dynamic_type (check_typedef (index_type)))
2221 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2222 low_bound = high_bound = 0;
2223 if (high_bound < low_bound)
2224 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2225 else
14f9c5c9
AS
2226 {
2227 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2228 TYPE_LENGTH (new_type) =
4c4b4cd2 2229 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2230 }
2231
876cecd0 2232 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2233 return new_type;
2234}
2235
ad82864c
JB
2236/* The array type encoded by TYPE, where
2237 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2238
d2e4a39e 2239static struct type *
ad82864c 2240decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2241{
0d5cff50 2242 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2243 char *name;
0d5cff50 2244 const char *tail;
d2e4a39e 2245 struct type *shadow_type;
14f9c5c9 2246 long bits;
14f9c5c9 2247
727e3d2e
JB
2248 if (!raw_name)
2249 raw_name = ada_type_name (desc_base_type (type));
2250
2251 if (!raw_name)
2252 return NULL;
2253
2254 name = (char *) alloca (strlen (raw_name) + 1);
2255 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2256 type = desc_base_type (type);
2257
14f9c5c9
AS
2258 memcpy (name, raw_name, tail - raw_name);
2259 name[tail - raw_name] = '\000';
2260
b4ba55a1
JB
2261 shadow_type = ada_find_parallel_type_with_name (type, name);
2262
2263 if (shadow_type == NULL)
14f9c5c9 2264 {
323e0a4a 2265 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2266 return NULL;
2267 }
f168693b 2268 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2269
2270 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2271 {
0963b4bd
MS
2272 lim_warning (_("could not understand bounds "
2273 "information on packed array"));
14f9c5c9
AS
2274 return NULL;
2275 }
d2e4a39e 2276
ad82864c
JB
2277 bits = decode_packed_array_bitsize (type);
2278 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2279}
2280
ad82864c
JB
2281/* Given that ARR is a struct value *indicating a GNAT constrained packed
2282 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2283 standard GDB array type except that the BITSIZEs of the array
2284 target types are set to the number of bits in each element, and the
4c4b4cd2 2285 type length is set appropriately. */
14f9c5c9 2286
d2e4a39e 2287static struct value *
ad82864c 2288decode_constrained_packed_array (struct value *arr)
14f9c5c9 2289{
4c4b4cd2 2290 struct type *type;
14f9c5c9 2291
11aa919a
PMR
2292 /* If our value is a pointer, then dereference it. Likewise if
2293 the value is a reference. Make sure that this operation does not
2294 cause the target type to be fixed, as this would indirectly cause
2295 this array to be decoded. The rest of the routine assumes that
2296 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2297 and "value_ind" routines to perform the dereferencing, as opposed
2298 to using "ada_coerce_ref" or "ada_value_ind". */
2299 arr = coerce_ref (arr);
828292f2 2300 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2301 arr = value_ind (arr);
4c4b4cd2 2302
ad82864c 2303 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2304 if (type == NULL)
2305 {
323e0a4a 2306 error (_("can't unpack array"));
14f9c5c9
AS
2307 return NULL;
2308 }
61ee279c 2309
50810684 2310 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2311 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2312 {
2313 /* This is a (right-justified) modular type representing a packed
2314 array with no wrapper. In order to interpret the value through
2315 the (left-justified) packed array type we just built, we must
2316 first left-justify it. */
2317 int bit_size, bit_pos;
2318 ULONGEST mod;
2319
df407dfe 2320 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2321 bit_size = 0;
2322 while (mod > 0)
2323 {
2324 bit_size += 1;
2325 mod >>= 1;
2326 }
df407dfe 2327 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2328 arr = ada_value_primitive_packed_val (arr, NULL,
2329 bit_pos / HOST_CHAR_BIT,
2330 bit_pos % HOST_CHAR_BIT,
2331 bit_size,
2332 type);
2333 }
2334
4c4b4cd2 2335 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2336}
2337
2338
2339/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2340 given in IND. ARR must be a simple array. */
14f9c5c9 2341
d2e4a39e
AS
2342static struct value *
2343value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2344{
2345 int i;
2346 int bits, elt_off, bit_off;
2347 long elt_total_bit_offset;
d2e4a39e
AS
2348 struct type *elt_type;
2349 struct value *v;
14f9c5c9
AS
2350
2351 bits = 0;
2352 elt_total_bit_offset = 0;
df407dfe 2353 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2354 for (i = 0; i < arity; i += 1)
14f9c5c9 2355 {
d2e4a39e 2356 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2357 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2358 error
0963b4bd
MS
2359 (_("attempt to do packed indexing of "
2360 "something other than a packed array"));
14f9c5c9 2361 else
4c4b4cd2
PH
2362 {
2363 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2364 LONGEST lowerbound, upperbound;
2365 LONGEST idx;
2366
2367 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2368 {
323e0a4a 2369 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2370 lowerbound = upperbound = 0;
2371 }
2372
3cb382c9 2373 idx = pos_atr (ind[i]);
4c4b4cd2 2374 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2375 lim_warning (_("packed array index %ld out of bounds"),
2376 (long) idx);
4c4b4cd2
PH
2377 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2378 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2379 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2380 }
14f9c5c9
AS
2381 }
2382 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2383 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2384
2385 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2386 bits, elt_type);
14f9c5c9
AS
2387 return v;
2388}
2389
4c4b4cd2 2390/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2391
2392static int
d2e4a39e 2393has_negatives (struct type *type)
14f9c5c9 2394{
d2e4a39e
AS
2395 switch (TYPE_CODE (type))
2396 {
2397 default:
2398 return 0;
2399 case TYPE_CODE_INT:
2400 return !TYPE_UNSIGNED (type);
2401 case TYPE_CODE_RANGE:
2402 return TYPE_LOW_BOUND (type) < 0;
2403 }
14f9c5c9 2404}
d2e4a39e 2405
f93fca70 2406/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2407 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2408 the unpacked buffer.
14f9c5c9 2409
5b639dea
JB
2410 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2411 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2412
f93fca70
JB
2413 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2414 zero otherwise.
14f9c5c9 2415
f93fca70 2416 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2417
f93fca70
JB
2418 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2419
2420static void
2421ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2422 gdb_byte *unpacked, int unpacked_len,
2423 int is_big_endian, int is_signed_type,
2424 int is_scalar)
2425{
a1c95e6b
JB
2426 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2427 int src_idx; /* Index into the source area */
2428 int src_bytes_left; /* Number of source bytes left to process. */
2429 int srcBitsLeft; /* Number of source bits left to move */
2430 int unusedLS; /* Number of bits in next significant
2431 byte of source that are unused */
2432
a1c95e6b
JB
2433 int unpacked_idx; /* Index into the unpacked buffer */
2434 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2435
4c4b4cd2 2436 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2437 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2438 unsigned char sign;
a1c95e6b 2439
4c4b4cd2
PH
2440 /* Transmit bytes from least to most significant; delta is the direction
2441 the indices move. */
f93fca70 2442 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2443
5b639dea
JB
2444 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2445 bits from SRC. .*/
2446 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2447 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2448 bit_size, unpacked_len);
2449
14f9c5c9 2450 srcBitsLeft = bit_size;
086ca51f 2451 src_bytes_left = src_len;
f93fca70 2452 unpacked_bytes_left = unpacked_len;
14f9c5c9 2453 sign = 0;
f93fca70
JB
2454
2455 if (is_big_endian)
14f9c5c9 2456 {
086ca51f 2457 src_idx = src_len - 1;
f93fca70
JB
2458 if (is_signed_type
2459 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2460 sign = ~0;
d2e4a39e
AS
2461
2462 unusedLS =
4c4b4cd2
PH
2463 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2464 % HOST_CHAR_BIT;
14f9c5c9 2465
f93fca70
JB
2466 if (is_scalar)
2467 {
2468 accumSize = 0;
2469 unpacked_idx = unpacked_len - 1;
2470 }
2471 else
2472 {
4c4b4cd2
PH
2473 /* Non-scalar values must be aligned at a byte boundary... */
2474 accumSize =
2475 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2476 /* ... And are placed at the beginning (most-significant) bytes
2477 of the target. */
086ca51f
JB
2478 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2479 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2480 }
14f9c5c9 2481 }
d2e4a39e 2482 else
14f9c5c9
AS
2483 {
2484 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2485
086ca51f 2486 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2487 unusedLS = bit_offset;
2488 accumSize = 0;
2489
f93fca70 2490 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2491 sign = ~0;
14f9c5c9 2492 }
d2e4a39e 2493
14f9c5c9 2494 accum = 0;
086ca51f 2495 while (src_bytes_left > 0)
14f9c5c9
AS
2496 {
2497 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2498 part of the value. */
d2e4a39e 2499 unsigned int unusedMSMask =
4c4b4cd2
PH
2500 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2501 1;
2502 /* Sign-extend bits for this byte. */
14f9c5c9 2503 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2504
d2e4a39e 2505 accum |=
086ca51f 2506 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2507 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2508 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2509 {
db297a65 2510 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2511 accumSize -= HOST_CHAR_BIT;
2512 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2513 unpacked_bytes_left -= 1;
2514 unpacked_idx += delta;
4c4b4cd2 2515 }
14f9c5c9
AS
2516 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2517 unusedLS = 0;
086ca51f
JB
2518 src_bytes_left -= 1;
2519 src_idx += delta;
14f9c5c9 2520 }
086ca51f 2521 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2522 {
2523 accum |= sign << accumSize;
db297a65 2524 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2525 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2526 if (accumSize < 0)
2527 accumSize = 0;
14f9c5c9 2528 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2529 unpacked_bytes_left -= 1;
2530 unpacked_idx += delta;
14f9c5c9 2531 }
f93fca70
JB
2532}
2533
2534/* Create a new value of type TYPE from the contents of OBJ starting
2535 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2536 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2537 assigning through the result will set the field fetched from.
2538 VALADDR is ignored unless OBJ is NULL, in which case,
2539 VALADDR+OFFSET must address the start of storage containing the
2540 packed value. The value returned in this case is never an lval.
2541 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2542
2543struct value *
2544ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2545 long offset, int bit_offset, int bit_size,
2546 struct type *type)
2547{
2548 struct value *v;
bfb1c796 2549 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2550 gdb_byte *unpacked;
220475ed 2551 const int is_scalar = is_scalar_type (type);
d0a9e810 2552 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2553 gdb::byte_vector staging;
f93fca70
JB
2554
2555 type = ada_check_typedef (type);
2556
d0a9e810 2557 if (obj == NULL)
bfb1c796 2558 src = valaddr + offset;
d0a9e810 2559 else
bfb1c796 2560 src = value_contents (obj) + offset;
d0a9e810
JB
2561
2562 if (is_dynamic_type (type))
2563 {
2564 /* The length of TYPE might by dynamic, so we need to resolve
2565 TYPE in order to know its actual size, which we then use
2566 to create the contents buffer of the value we return.
2567 The difficulty is that the data containing our object is
2568 packed, and therefore maybe not at a byte boundary. So, what
2569 we do, is unpack the data into a byte-aligned buffer, and then
2570 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2571 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2572 staging.resize (staging_len);
d0a9e810
JB
2573
2574 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2575 staging.data (), staging.size (),
d0a9e810
JB
2576 is_big_endian, has_negatives (type),
2577 is_scalar);
d5722aa2 2578 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2579 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2580 {
2581 /* This happens when the length of the object is dynamic,
2582 and is actually smaller than the space reserved for it.
2583 For instance, in an array of variant records, the bit_size
2584 we're given is the array stride, which is constant and
2585 normally equal to the maximum size of its element.
2586 But, in reality, each element only actually spans a portion
2587 of that stride. */
2588 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2589 }
d0a9e810
JB
2590 }
2591
f93fca70
JB
2592 if (obj == NULL)
2593 {
2594 v = allocate_value (type);
bfb1c796 2595 src = valaddr + offset;
f93fca70
JB
2596 }
2597 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2598 {
0cafa88c 2599 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2600 gdb_byte *buf;
0cafa88c 2601
f93fca70 2602 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2603 buf = (gdb_byte *) alloca (src_len);
2604 read_memory (value_address (v), buf, src_len);
2605 src = buf;
f93fca70
JB
2606 }
2607 else
2608 {
2609 v = allocate_value (type);
bfb1c796 2610 src = value_contents (obj) + offset;
f93fca70
JB
2611 }
2612
2613 if (obj != NULL)
2614 {
2615 long new_offset = offset;
2616
2617 set_value_component_location (v, obj);
2618 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2619 set_value_bitsize (v, bit_size);
2620 if (value_bitpos (v) >= HOST_CHAR_BIT)
2621 {
2622 ++new_offset;
2623 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2624 }
2625 set_value_offset (v, new_offset);
2626
2627 /* Also set the parent value. This is needed when trying to
2628 assign a new value (in inferior memory). */
2629 set_value_parent (v, obj);
2630 }
2631 else
2632 set_value_bitsize (v, bit_size);
bfb1c796 2633 unpacked = value_contents_writeable (v);
f93fca70
JB
2634
2635 if (bit_size == 0)
2636 {
2637 memset (unpacked, 0, TYPE_LENGTH (type));
2638 return v;
2639 }
2640
d5722aa2 2641 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2642 {
d0a9e810
JB
2643 /* Small short-cut: If we've unpacked the data into a buffer
2644 of the same size as TYPE's length, then we can reuse that,
2645 instead of doing the unpacking again. */
d5722aa2 2646 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2647 }
d0a9e810
JB
2648 else
2649 ada_unpack_from_contents (src, bit_offset, bit_size,
2650 unpacked, TYPE_LENGTH (type),
2651 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2652
14f9c5c9
AS
2653 return v;
2654}
d2e4a39e 2655
14f9c5c9
AS
2656/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2657 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2658 not overlap. */
14f9c5c9 2659static void
fc1a4b47 2660move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2661 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2662{
2663 unsigned int accum, mask;
2664 int accum_bits, chunk_size;
2665
2666 target += targ_offset / HOST_CHAR_BIT;
2667 targ_offset %= HOST_CHAR_BIT;
2668 source += src_offset / HOST_CHAR_BIT;
2669 src_offset %= HOST_CHAR_BIT;
50810684 2670 if (bits_big_endian_p)
14f9c5c9
AS
2671 {
2672 accum = (unsigned char) *source;
2673 source += 1;
2674 accum_bits = HOST_CHAR_BIT - src_offset;
2675
d2e4a39e 2676 while (n > 0)
4c4b4cd2
PH
2677 {
2678 int unused_right;
5b4ee69b 2679
4c4b4cd2
PH
2680 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2681 accum_bits += HOST_CHAR_BIT;
2682 source += 1;
2683 chunk_size = HOST_CHAR_BIT - targ_offset;
2684 if (chunk_size > n)
2685 chunk_size = n;
2686 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2687 mask = ((1 << chunk_size) - 1) << unused_right;
2688 *target =
2689 (*target & ~mask)
2690 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2691 n -= chunk_size;
2692 accum_bits -= chunk_size;
2693 target += 1;
2694 targ_offset = 0;
2695 }
14f9c5c9
AS
2696 }
2697 else
2698 {
2699 accum = (unsigned char) *source >> src_offset;
2700 source += 1;
2701 accum_bits = HOST_CHAR_BIT - src_offset;
2702
d2e4a39e 2703 while (n > 0)
4c4b4cd2
PH
2704 {
2705 accum = accum + ((unsigned char) *source << accum_bits);
2706 accum_bits += HOST_CHAR_BIT;
2707 source += 1;
2708 chunk_size = HOST_CHAR_BIT - targ_offset;
2709 if (chunk_size > n)
2710 chunk_size = n;
2711 mask = ((1 << chunk_size) - 1) << targ_offset;
2712 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2713 n -= chunk_size;
2714 accum_bits -= chunk_size;
2715 accum >>= chunk_size;
2716 target += 1;
2717 targ_offset = 0;
2718 }
14f9c5c9
AS
2719 }
2720}
2721
14f9c5c9
AS
2722/* Store the contents of FROMVAL into the location of TOVAL.
2723 Return a new value with the location of TOVAL and contents of
2724 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2725 floating-point or non-scalar types. */
14f9c5c9 2726
d2e4a39e
AS
2727static struct value *
2728ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2729{
df407dfe
AC
2730 struct type *type = value_type (toval);
2731 int bits = value_bitsize (toval);
14f9c5c9 2732
52ce6436
PH
2733 toval = ada_coerce_ref (toval);
2734 fromval = ada_coerce_ref (fromval);
2735
2736 if (ada_is_direct_array_type (value_type (toval)))
2737 toval = ada_coerce_to_simple_array (toval);
2738 if (ada_is_direct_array_type (value_type (fromval)))
2739 fromval = ada_coerce_to_simple_array (fromval);
2740
88e3b34b 2741 if (!deprecated_value_modifiable (toval))
323e0a4a 2742 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2743
d2e4a39e 2744 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2745 && bits > 0
d2e4a39e 2746 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2747 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2748 {
df407dfe
AC
2749 int len = (value_bitpos (toval)
2750 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2751 int from_size;
224c3ddb 2752 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2753 struct value *val;
42ae5230 2754 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2755
2756 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2757 fromval = value_cast (type, fromval);
14f9c5c9 2758
52ce6436 2759 read_memory (to_addr, buffer, len);
aced2898
PH
2760 from_size = value_bitsize (fromval);
2761 if (from_size == 0)
2762 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2763 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2764 move_bits (buffer, value_bitpos (toval),
50810684 2765 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2766 else
50810684
UW
2767 move_bits (buffer, value_bitpos (toval),
2768 value_contents (fromval), 0, bits, 0);
972daa01 2769 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2770
14f9c5c9 2771 val = value_copy (toval);
0fd88904 2772 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2773 TYPE_LENGTH (type));
04624583 2774 deprecated_set_value_type (val, type);
d2e4a39e 2775
14f9c5c9
AS
2776 return val;
2777 }
2778
2779 return value_assign (toval, fromval);
2780}
2781
2782
7c512744
JB
2783/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2784 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2785 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2786 COMPONENT, and not the inferior's memory. The current contents
2787 of COMPONENT are ignored.
2788
2789 Although not part of the initial design, this function also works
2790 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2791 had a null address, and COMPONENT had an address which is equal to
2792 its offset inside CONTAINER. */
2793
52ce6436
PH
2794static void
2795value_assign_to_component (struct value *container, struct value *component,
2796 struct value *val)
2797{
2798 LONGEST offset_in_container =
42ae5230 2799 (LONGEST) (value_address (component) - value_address (container));
7c512744 2800 int bit_offset_in_container =
52ce6436
PH
2801 value_bitpos (component) - value_bitpos (container);
2802 int bits;
7c512744 2803
52ce6436
PH
2804 val = value_cast (value_type (component), val);
2805
2806 if (value_bitsize (component) == 0)
2807 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2808 else
2809 bits = value_bitsize (component);
2810
50810684 2811 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2a62dfa9
JB
2812 {
2813 int src_offset;
2814
2815 if (is_scalar_type (check_typedef (value_type (component))))
2816 src_offset
2817 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2818 else
2819 src_offset = 0;
2820 move_bits (value_contents_writeable (container) + offset_in_container,
2821 value_bitpos (container) + bit_offset_in_container,
2822 value_contents (val), src_offset, bits, 1);
2823 }
52ce6436 2824 else
7c512744 2825 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2826 value_bitpos (container) + bit_offset_in_container,
50810684 2827 value_contents (val), 0, bits, 0);
7c512744
JB
2828}
2829
4c4b4cd2
PH
2830/* The value of the element of array ARR at the ARITY indices given in IND.
2831 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2832 thereto. */
2833
d2e4a39e
AS
2834struct value *
2835ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2836{
2837 int k;
d2e4a39e
AS
2838 struct value *elt;
2839 struct type *elt_type;
14f9c5c9
AS
2840
2841 elt = ada_coerce_to_simple_array (arr);
2842
df407dfe 2843 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2844 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2845 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2846 return value_subscript_packed (elt, arity, ind);
2847
2848 for (k = 0; k < arity; k += 1)
2849 {
2850 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2851 error (_("too many subscripts (%d expected)"), k);
2497b498 2852 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2853 }
2854 return elt;
2855}
2856
deede10c
JB
2857/* Assuming ARR is a pointer to a GDB array, the value of the element
2858 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2859 Does not read the entire array into memory.
2860
2861 Note: Unlike what one would expect, this function is used instead of
2862 ada_value_subscript for basically all non-packed array types. The reason
2863 for this is that a side effect of doing our own pointer arithmetics instead
2864 of relying on value_subscript is that there is no implicit typedef peeling.
2865 This is important for arrays of array accesses, where it allows us to
2866 preserve the fact that the array's element is an array access, where the
2867 access part os encoded in a typedef layer. */
14f9c5c9 2868
2c0b251b 2869static struct value *
deede10c 2870ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2871{
2872 int k;
919e6dbe 2873 struct value *array_ind = ada_value_ind (arr);
deede10c 2874 struct type *type
919e6dbe
PMR
2875 = check_typedef (value_enclosing_type (array_ind));
2876
2877 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2878 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2879 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2880
2881 for (k = 0; k < arity; k += 1)
2882 {
2883 LONGEST lwb, upb;
aa715135 2884 struct value *lwb_value;
14f9c5c9
AS
2885
2886 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2887 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2888 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2889 value_copy (arr));
14f9c5c9 2890 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2891 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2892 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2893 type = TYPE_TARGET_TYPE (type);
2894 }
2895
2896 return value_ind (arr);
2897}
2898
0b5d8877 2899/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2900 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2901 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2902 this array is LOW, as per Ada rules. */
0b5d8877 2903static struct value *
f5938064
JG
2904ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2905 int low, int high)
0b5d8877 2906{
b0dd7688 2907 struct type *type0 = ada_check_typedef (type);
aa715135 2908 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2909 struct type *index_type
aa715135 2910 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2911 struct type *slice_type = create_array_type_with_stride
2912 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2913 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2914 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2915 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2916 LONGEST base_low_pos, low_pos;
2917 CORE_ADDR base;
2918
2919 if (!discrete_position (base_index_type, low, &low_pos)
2920 || !discrete_position (base_index_type, base_low, &base_low_pos))
2921 {
2922 warning (_("unable to get positions in slice, use bounds instead"));
2923 low_pos = low;
2924 base_low_pos = base_low;
2925 }
5b4ee69b 2926
aa715135
JG
2927 base = value_as_address (array_ptr)
2928 + ((low_pos - base_low_pos)
2929 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2930 return value_at_lazy (slice_type, base);
0b5d8877
PH
2931}
2932
2933
2934static struct value *
2935ada_value_slice (struct value *array, int low, int high)
2936{
b0dd7688 2937 struct type *type = ada_check_typedef (value_type (array));
aa715135 2938 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2939 struct type *index_type
2940 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2941 struct type *slice_type = create_array_type_with_stride
2942 (NULL, TYPE_TARGET_TYPE (type), index_type,
2943 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2944 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2945 LONGEST low_pos, high_pos;
5b4ee69b 2946
aa715135
JG
2947 if (!discrete_position (base_index_type, low, &low_pos)
2948 || !discrete_position (base_index_type, high, &high_pos))
2949 {
2950 warning (_("unable to get positions in slice, use bounds instead"));
2951 low_pos = low;
2952 high_pos = high;
2953 }
2954
2955 return value_cast (slice_type,
2956 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2957}
2958
14f9c5c9
AS
2959/* If type is a record type in the form of a standard GNAT array
2960 descriptor, returns the number of dimensions for type. If arr is a
2961 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2962 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2963
2964int
d2e4a39e 2965ada_array_arity (struct type *type)
14f9c5c9
AS
2966{
2967 int arity;
2968
2969 if (type == NULL)
2970 return 0;
2971
2972 type = desc_base_type (type);
2973
2974 arity = 0;
d2e4a39e 2975 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2976 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2977 else
2978 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2979 {
4c4b4cd2 2980 arity += 1;
61ee279c 2981 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2982 }
d2e4a39e 2983
14f9c5c9
AS
2984 return arity;
2985}
2986
2987/* If TYPE is a record type in the form of a standard GNAT array
2988 descriptor or a simple array type, returns the element type for
2989 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2990 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2991
d2e4a39e
AS
2992struct type *
2993ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2994{
2995 type = desc_base_type (type);
2996
d2e4a39e 2997 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2998 {
2999 int k;
d2e4a39e 3000 struct type *p_array_type;
14f9c5c9 3001
556bdfd4 3002 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
3003
3004 k = ada_array_arity (type);
3005 if (k == 0)
4c4b4cd2 3006 return NULL;
d2e4a39e 3007
4c4b4cd2 3008 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 3009 if (nindices >= 0 && k > nindices)
4c4b4cd2 3010 k = nindices;
d2e4a39e 3011 while (k > 0 && p_array_type != NULL)
4c4b4cd2 3012 {
61ee279c 3013 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
3014 k -= 1;
3015 }
14f9c5c9
AS
3016 return p_array_type;
3017 }
3018 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3019 {
3020 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3021 {
3022 type = TYPE_TARGET_TYPE (type);
3023 nindices -= 1;
3024 }
14f9c5c9
AS
3025 return type;
3026 }
3027
3028 return NULL;
3029}
3030
4c4b4cd2 3031/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3032 Does not examine memory. Throws an error if N is invalid or TYPE
3033 is not an array type. NAME is the name of the Ada attribute being
3034 evaluated ('range, 'first, 'last, or 'length); it is used in building
3035 the error message. */
14f9c5c9 3036
1eea4ebd
UW
3037static struct type *
3038ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3039{
4c4b4cd2
PH
3040 struct type *result_type;
3041
14f9c5c9
AS
3042 type = desc_base_type (type);
3043
1eea4ebd
UW
3044 if (n < 0 || n > ada_array_arity (type))
3045 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3046
4c4b4cd2 3047 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3048 {
3049 int i;
3050
3051 for (i = 1; i < n; i += 1)
4c4b4cd2 3052 type = TYPE_TARGET_TYPE (type);
262452ec 3053 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3054 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3055 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3056 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3057 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3058 result_type = NULL;
14f9c5c9 3059 }
d2e4a39e 3060 else
1eea4ebd
UW
3061 {
3062 result_type = desc_index_type (desc_bounds_type (type), n);
3063 if (result_type == NULL)
3064 error (_("attempt to take bound of something that is not an array"));
3065 }
3066
3067 return result_type;
14f9c5c9
AS
3068}
3069
3070/* Given that arr is an array type, returns the lower bound of the
3071 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3072 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3073 array-descriptor type. It works for other arrays with bounds supplied
3074 by run-time quantities other than discriminants. */
14f9c5c9 3075
abb68b3e 3076static LONGEST
fb5e3d5c 3077ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3078{
8a48ac95 3079 struct type *type, *index_type_desc, *index_type;
1ce677a4 3080 int i;
262452ec
JK
3081
3082 gdb_assert (which == 0 || which == 1);
14f9c5c9 3083
ad82864c
JB
3084 if (ada_is_constrained_packed_array_type (arr_type))
3085 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3086
4c4b4cd2 3087 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3088 return (LONGEST) - which;
14f9c5c9
AS
3089
3090 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3091 type = TYPE_TARGET_TYPE (arr_type);
3092 else
3093 type = arr_type;
3094
bafffb51
JB
3095 if (TYPE_FIXED_INSTANCE (type))
3096 {
3097 /* The array has already been fixed, so we do not need to
3098 check the parallel ___XA type again. That encoding has
3099 already been applied, so ignore it now. */
3100 index_type_desc = NULL;
3101 }
3102 else
3103 {
3104 index_type_desc = ada_find_parallel_type (type, "___XA");
3105 ada_fixup_array_indexes_type (index_type_desc);
3106 }
3107
262452ec 3108 if (index_type_desc != NULL)
28c85d6c
JB
3109 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3110 NULL);
262452ec 3111 else
8a48ac95
JB
3112 {
3113 struct type *elt_type = check_typedef (type);
3114
3115 for (i = 1; i < n; i++)
3116 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3117
3118 index_type = TYPE_INDEX_TYPE (elt_type);
3119 }
262452ec 3120
43bbcdc2
PH
3121 return
3122 (LONGEST) (which == 0
3123 ? ada_discrete_type_low_bound (index_type)
3124 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3125}
3126
3127/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3128 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3129 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3130 supplied by run-time quantities other than discriminants. */
14f9c5c9 3131
1eea4ebd 3132static LONGEST
4dc81987 3133ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3134{
eb479039
JB
3135 struct type *arr_type;
3136
3137 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3138 arr = value_ind (arr);
3139 arr_type = value_enclosing_type (arr);
14f9c5c9 3140
ad82864c
JB
3141 if (ada_is_constrained_packed_array_type (arr_type))
3142 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3143 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3144 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3145 else
1eea4ebd 3146 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3147}
3148
3149/* Given that arr is an array value, returns the length of the
3150 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3151 supplied by run-time quantities other than discriminants.
3152 Does not work for arrays indexed by enumeration types with representation
3153 clauses at the moment. */
14f9c5c9 3154
1eea4ebd 3155static LONGEST
d2e4a39e 3156ada_array_length (struct value *arr, int n)
14f9c5c9 3157{
aa715135
JG
3158 struct type *arr_type, *index_type;
3159 int low, high;
eb479039
JB
3160
3161 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3162 arr = value_ind (arr);
3163 arr_type = value_enclosing_type (arr);
14f9c5c9 3164
ad82864c
JB
3165 if (ada_is_constrained_packed_array_type (arr_type))
3166 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3167
4c4b4cd2 3168 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3169 {
3170 low = ada_array_bound_from_type (arr_type, n, 0);
3171 high = ada_array_bound_from_type (arr_type, n, 1);
3172 }
14f9c5c9 3173 else
aa715135
JG
3174 {
3175 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3176 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3177 }
3178
f168693b 3179 arr_type = check_typedef (arr_type);
7150d33c 3180 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3181 if (index_type != NULL)
3182 {
3183 struct type *base_type;
3184 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3185 base_type = TYPE_TARGET_TYPE (index_type);
3186 else
3187 base_type = index_type;
3188
3189 low = pos_atr (value_from_longest (base_type, low));
3190 high = pos_atr (value_from_longest (base_type, high));
3191 }
3192 return high - low + 1;
4c4b4cd2
PH
3193}
3194
3195/* An empty array whose type is that of ARR_TYPE (an array type),
3196 with bounds LOW to LOW-1. */
3197
3198static struct value *
3199empty_array (struct type *arr_type, int low)
3200{
b0dd7688 3201 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3202 struct type *index_type
3203 = create_static_range_type
3204 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3205 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3206
0b5d8877 3207 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3208}
14f9c5c9 3209\f
d2e4a39e 3210
4c4b4cd2 3211 /* Name resolution */
14f9c5c9 3212
4c4b4cd2
PH
3213/* The "decoded" name for the user-definable Ada operator corresponding
3214 to OP. */
14f9c5c9 3215
d2e4a39e 3216static const char *
4c4b4cd2 3217ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3218{
3219 int i;
3220
4c4b4cd2 3221 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3222 {
3223 if (ada_opname_table[i].op == op)
4c4b4cd2 3224 return ada_opname_table[i].decoded;
14f9c5c9 3225 }
323e0a4a 3226 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3227}
3228
3229
4c4b4cd2
PH
3230/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3231 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3232 undefined namespace) and converts operators that are
3233 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3234 non-null, it provides a preferred result type [at the moment, only
3235 type void has any effect---causing procedures to be preferred over
3236 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3237 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3238
4c4b4cd2 3239static void
e9d9f57e 3240resolve (expression_up *expp, int void_context_p)
14f9c5c9 3241{
30b15541
UW
3242 struct type *context_type = NULL;
3243 int pc = 0;
3244
3245 if (void_context_p)
3246 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3247
3248 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3249}
3250
4c4b4cd2
PH
3251/* Resolve the operator of the subexpression beginning at
3252 position *POS of *EXPP. "Resolving" consists of replacing
3253 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3254 with their resolutions, replacing built-in operators with
3255 function calls to user-defined operators, where appropriate, and,
3256 when DEPROCEDURE_P is non-zero, converting function-valued variables
3257 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3258 are as in ada_resolve, above. */
14f9c5c9 3259
d2e4a39e 3260static struct value *
e9d9f57e 3261resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
76a01679 3262 struct type *context_type)
14f9c5c9
AS
3263{
3264 int pc = *pos;
3265 int i;
4c4b4cd2 3266 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3267 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3268 struct value **argvec; /* Vector of operand types (alloca'ed). */
3269 int nargs; /* Number of operands. */
52ce6436 3270 int oplen;
14f9c5c9
AS
3271
3272 argvec = NULL;
3273 nargs = 0;
e9d9f57e 3274 exp = expp->get ();
14f9c5c9 3275
52ce6436
PH
3276 /* Pass one: resolve operands, saving their types and updating *pos,
3277 if needed. */
14f9c5c9
AS
3278 switch (op)
3279 {
4c4b4cd2
PH
3280 case OP_FUNCALL:
3281 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3282 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3283 *pos += 7;
4c4b4cd2
PH
3284 else
3285 {
3286 *pos += 3;
3287 resolve_subexp (expp, pos, 0, NULL);
3288 }
3289 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3290 break;
3291
14f9c5c9 3292 case UNOP_ADDR:
4c4b4cd2
PH
3293 *pos += 1;
3294 resolve_subexp (expp, pos, 0, NULL);
3295 break;
3296
52ce6436
PH
3297 case UNOP_QUAL:
3298 *pos += 3;
17466c1a 3299 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3300 break;
3301
52ce6436 3302 case OP_ATR_MODULUS:
4c4b4cd2
PH
3303 case OP_ATR_SIZE:
3304 case OP_ATR_TAG:
4c4b4cd2
PH
3305 case OP_ATR_FIRST:
3306 case OP_ATR_LAST:
3307 case OP_ATR_LENGTH:
3308 case OP_ATR_POS:
3309 case OP_ATR_VAL:
4c4b4cd2
PH
3310 case OP_ATR_MIN:
3311 case OP_ATR_MAX:
52ce6436
PH
3312 case TERNOP_IN_RANGE:
3313 case BINOP_IN_BOUNDS:
3314 case UNOP_IN_RANGE:
3315 case OP_AGGREGATE:
3316 case OP_OTHERS:
3317 case OP_CHOICES:
3318 case OP_POSITIONAL:
3319 case OP_DISCRETE_RANGE:
3320 case OP_NAME:
3321 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3322 *pos += oplen;
14f9c5c9
AS
3323 break;
3324
3325 case BINOP_ASSIGN:
3326 {
4c4b4cd2
PH
3327 struct value *arg1;
3328
3329 *pos += 1;
3330 arg1 = resolve_subexp (expp, pos, 0, NULL);
3331 if (arg1 == NULL)
3332 resolve_subexp (expp, pos, 1, NULL);
3333 else
df407dfe 3334 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3335 break;
14f9c5c9
AS
3336 }
3337
4c4b4cd2 3338 case UNOP_CAST:
4c4b4cd2
PH
3339 *pos += 3;
3340 nargs = 1;
3341 break;
14f9c5c9 3342
4c4b4cd2
PH
3343 case BINOP_ADD:
3344 case BINOP_SUB:
3345 case BINOP_MUL:
3346 case BINOP_DIV:
3347 case BINOP_REM:
3348 case BINOP_MOD:
3349 case BINOP_EXP:
3350 case BINOP_CONCAT:
3351 case BINOP_LOGICAL_AND:
3352 case BINOP_LOGICAL_OR:
3353 case BINOP_BITWISE_AND:
3354 case BINOP_BITWISE_IOR:
3355 case BINOP_BITWISE_XOR:
14f9c5c9 3356
4c4b4cd2
PH
3357 case BINOP_EQUAL:
3358 case BINOP_NOTEQUAL:
3359 case BINOP_LESS:
3360 case BINOP_GTR:
3361 case BINOP_LEQ:
3362 case BINOP_GEQ:
14f9c5c9 3363
4c4b4cd2
PH
3364 case BINOP_REPEAT:
3365 case BINOP_SUBSCRIPT:
3366 case BINOP_COMMA:
40c8aaa9
JB
3367 *pos += 1;
3368 nargs = 2;
3369 break;
14f9c5c9 3370
4c4b4cd2
PH
3371 case UNOP_NEG:
3372 case UNOP_PLUS:
3373 case UNOP_LOGICAL_NOT:
3374 case UNOP_ABS:
3375 case UNOP_IND:
3376 *pos += 1;
3377 nargs = 1;
3378 break;
14f9c5c9 3379
4c4b4cd2 3380 case OP_LONG:
edd079d9 3381 case OP_FLOAT:
4c4b4cd2 3382 case OP_VAR_VALUE:
74ea4be4 3383 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3384 *pos += 4;
3385 break;
14f9c5c9 3386
4c4b4cd2
PH
3387 case OP_TYPE:
3388 case OP_BOOL:
3389 case OP_LAST:
4c4b4cd2
PH
3390 case OP_INTERNALVAR:
3391 *pos += 3;
3392 break;
14f9c5c9 3393
4c4b4cd2
PH
3394 case UNOP_MEMVAL:
3395 *pos += 3;
3396 nargs = 1;
3397 break;
3398
67f3407f
DJ
3399 case OP_REGISTER:
3400 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3401 break;
3402
4c4b4cd2
PH
3403 case STRUCTOP_STRUCT:
3404 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3405 nargs = 1;
3406 break;
3407
4c4b4cd2 3408 case TERNOP_SLICE:
4c4b4cd2
PH
3409 *pos += 1;
3410 nargs = 3;
3411 break;
3412
52ce6436 3413 case OP_STRING:
14f9c5c9 3414 break;
4c4b4cd2
PH
3415
3416 default:
323e0a4a 3417 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3418 }
3419
8d749320 3420 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2
PH
3421 for (i = 0; i < nargs; i += 1)
3422 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3423 argvec[i] = NULL;
e9d9f57e 3424 exp = expp->get ();
4c4b4cd2
PH
3425
3426 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3427 switch (op)
3428 {
3429 default:
3430 break;
3431
14f9c5c9 3432 case OP_VAR_VALUE:
4c4b4cd2 3433 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3434 {
54d343a2 3435 std::vector<struct block_symbol> candidates;
76a01679
JB
3436 int n_candidates;
3437
3438 n_candidates =
3439 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3440 (exp->elts[pc + 2].symbol),
3441 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3442 &candidates);
76a01679
JB
3443
3444 if (n_candidates > 1)
3445 {
3446 /* Types tend to get re-introduced locally, so if there
3447 are any local symbols that are not types, first filter
3448 out all types. */
3449 int j;
3450 for (j = 0; j < n_candidates; j += 1)
d12307c1 3451 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3452 {
3453 case LOC_REGISTER:
3454 case LOC_ARG:
3455 case LOC_REF_ARG:
76a01679
JB
3456 case LOC_REGPARM_ADDR:
3457 case LOC_LOCAL:
76a01679 3458 case LOC_COMPUTED:
76a01679
JB
3459 goto FoundNonType;
3460 default:
3461 break;
3462 }
3463 FoundNonType:
3464 if (j < n_candidates)
3465 {
3466 j = 0;
3467 while (j < n_candidates)
3468 {
d12307c1 3469 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3470 {
3471 candidates[j] = candidates[n_candidates - 1];
3472 n_candidates -= 1;
3473 }
3474 else
3475 j += 1;
3476 }
3477 }
3478 }
3479
3480 if (n_candidates == 0)
323e0a4a 3481 error (_("No definition found for %s"),
76a01679
JB
3482 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3483 else if (n_candidates == 1)
3484 i = 0;
3485 else if (deprocedure_p
54d343a2 3486 && !is_nonfunction (candidates.data (), n_candidates))
76a01679 3487 {
06d5cf63 3488 i = ada_resolve_function
54d343a2 3489 (candidates.data (), n_candidates, NULL, 0,
06d5cf63
JB
3490 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3491 context_type);
76a01679 3492 if (i < 0)
323e0a4a 3493 error (_("Could not find a match for %s"),
76a01679
JB
3494 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3495 }
3496 else
3497 {
323e0a4a 3498 printf_filtered (_("Multiple matches for %s\n"),
76a01679 3499 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
54d343a2 3500 user_select_syms (candidates.data (), n_candidates, 1);
76a01679
JB
3501 i = 0;
3502 }
3503
3504 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3505 exp->elts[pc + 2].symbol = candidates[i].symbol;
aee1fcdf 3506 innermost_block.update (candidates[i]);
76a01679
JB
3507 }
3508
3509 if (deprocedure_p
3510 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3511 == TYPE_CODE_FUNC))
3512 {
3513 replace_operator_with_call (expp, pc, 0, 0,
3514 exp->elts[pc + 2].symbol,
3515 exp->elts[pc + 1].block);
e9d9f57e 3516 exp = expp->get ();
76a01679 3517 }
14f9c5c9
AS
3518 break;
3519
3520 case OP_FUNCALL:
3521 {
4c4b4cd2 3522 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3523 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3524 {
54d343a2 3525 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3526 int n_candidates;
3527
3528 n_candidates =
76a01679
JB
3529 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3530 (exp->elts[pc + 5].symbol),
3531 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3532 &candidates);
ec6a20c2 3533
4c4b4cd2
PH
3534 if (n_candidates == 1)
3535 i = 0;
3536 else
3537 {
06d5cf63 3538 i = ada_resolve_function
54d343a2 3539 (candidates.data (), n_candidates,
06d5cf63
JB
3540 argvec, nargs,
3541 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3542 context_type);
4c4b4cd2 3543 if (i < 0)
323e0a4a 3544 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3545 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3546 }
3547
3548 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3549 exp->elts[pc + 5].symbol = candidates[i].symbol;
aee1fcdf 3550 innermost_block.update (candidates[i]);
4c4b4cd2 3551 }
14f9c5c9
AS
3552 }
3553 break;
3554 case BINOP_ADD:
3555 case BINOP_SUB:
3556 case BINOP_MUL:
3557 case BINOP_DIV:
3558 case BINOP_REM:
3559 case BINOP_MOD:
3560 case BINOP_CONCAT:
3561 case BINOP_BITWISE_AND:
3562 case BINOP_BITWISE_IOR:
3563 case BINOP_BITWISE_XOR:
3564 case BINOP_EQUAL:
3565 case BINOP_NOTEQUAL:
3566 case BINOP_LESS:
3567 case BINOP_GTR:
3568 case BINOP_LEQ:
3569 case BINOP_GEQ:
3570 case BINOP_EXP:
3571 case UNOP_NEG:
3572 case UNOP_PLUS:
3573 case UNOP_LOGICAL_NOT:
3574 case UNOP_ABS:
3575 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3576 {
54d343a2 3577 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3578 int n_candidates;
3579
3580 n_candidates =
b5ec771e 3581 ada_lookup_symbol_list (ada_decoded_op_name (op),
4c4b4cd2 3582 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3583 &candidates);
ec6a20c2 3584
54d343a2
TT
3585 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3586 nargs, ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3587 if (i < 0)
3588 break;
3589
d12307c1
PMR
3590 replace_operator_with_call (expp, pc, nargs, 1,
3591 candidates[i].symbol,
3592 candidates[i].block);
e9d9f57e 3593 exp = expp->get ();
4c4b4cd2 3594 }
14f9c5c9 3595 break;
4c4b4cd2
PH
3596
3597 case OP_TYPE:
b3dbf008 3598 case OP_REGISTER:
4c4b4cd2 3599 return NULL;
14f9c5c9
AS
3600 }
3601
3602 *pos = pc;
ced9779b
JB
3603 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3604 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3605 exp->elts[pc + 1].objfile,
3606 exp->elts[pc + 2].msymbol);
3607 else
3608 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3609}
3610
3611/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3612 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3613 a non-pointer. */
14f9c5c9 3614/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3615 liberal. */
14f9c5c9
AS
3616
3617static int
4dc81987 3618ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3619{
61ee279c
PH
3620 ftype = ada_check_typedef (ftype);
3621 atype = ada_check_typedef (atype);
14f9c5c9
AS
3622
3623 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3624 ftype = TYPE_TARGET_TYPE (ftype);
3625 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3626 atype = TYPE_TARGET_TYPE (atype);
3627
d2e4a39e 3628 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3629 {
3630 default:
5b3d5b7d 3631 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3632 case TYPE_CODE_PTR:
3633 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3634 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3635 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3636 else
1265e4aa
JB
3637 return (may_deref
3638 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3639 case TYPE_CODE_INT:
3640 case TYPE_CODE_ENUM:
3641 case TYPE_CODE_RANGE:
3642 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3643 {
3644 case TYPE_CODE_INT:
3645 case TYPE_CODE_ENUM:
3646 case TYPE_CODE_RANGE:
3647 return 1;
3648 default:
3649 return 0;
3650 }
14f9c5c9
AS
3651
3652 case TYPE_CODE_ARRAY:
d2e4a39e 3653 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3654 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3655
3656 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3657 if (ada_is_array_descriptor_type (ftype))
3658 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3659 || ada_is_array_descriptor_type (atype));
14f9c5c9 3660 else
4c4b4cd2
PH
3661 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3662 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3663
3664 case TYPE_CODE_UNION:
3665 case TYPE_CODE_FLT:
3666 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3667 }
3668}
3669
3670/* Return non-zero if the formals of FUNC "sufficiently match" the
3671 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3672 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3673 argument function. */
14f9c5c9
AS
3674
3675static int
d2e4a39e 3676ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3677{
3678 int i;
d2e4a39e 3679 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3680
1265e4aa
JB
3681 if (SYMBOL_CLASS (func) == LOC_CONST
3682 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3683 return (n_actuals == 0);
3684 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3685 return 0;
3686
3687 if (TYPE_NFIELDS (func_type) != n_actuals)
3688 return 0;
3689
3690 for (i = 0; i < n_actuals; i += 1)
3691 {
4c4b4cd2 3692 if (actuals[i] == NULL)
76a01679
JB
3693 return 0;
3694 else
3695 {
5b4ee69b
MS
3696 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3697 i));
df407dfe 3698 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3699
76a01679
JB
3700 if (!ada_type_match (ftype, atype, 1))
3701 return 0;
3702 }
14f9c5c9
AS
3703 }
3704 return 1;
3705}
3706
3707/* False iff function type FUNC_TYPE definitely does not produce a value
3708 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3709 FUNC_TYPE is not a valid function type with a non-null return type
3710 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3711
3712static int
d2e4a39e 3713return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3714{
d2e4a39e 3715 struct type *return_type;
14f9c5c9
AS
3716
3717 if (func_type == NULL)
3718 return 1;
3719
4c4b4cd2 3720 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3721 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3722 else
18af8284 3723 return_type = get_base_type (func_type);
14f9c5c9
AS
3724 if (return_type == NULL)
3725 return 1;
3726
18af8284 3727 context_type = get_base_type (context_type);
14f9c5c9
AS
3728
3729 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3730 return context_type == NULL || return_type == context_type;
3731 else if (context_type == NULL)
3732 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3733 else
3734 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3735}
3736
3737
4c4b4cd2 3738/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3739 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3740 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3741 that returns that type, then eliminate matches that don't. If
3742 CONTEXT_TYPE is void and there is at least one match that does not
3743 return void, eliminate all matches that do.
3744
14f9c5c9
AS
3745 Asks the user if there is more than one match remaining. Returns -1
3746 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3747 solely for messages. May re-arrange and modify SYMS in
3748 the process; the index returned is for the modified vector. */
14f9c5c9 3749
4c4b4cd2 3750static int
d12307c1 3751ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3752 int nsyms, struct value **args, int nargs,
3753 const char *name, struct type *context_type)
14f9c5c9 3754{
30b15541 3755 int fallback;
14f9c5c9 3756 int k;
4c4b4cd2 3757 int m; /* Number of hits */
14f9c5c9 3758
d2e4a39e 3759 m = 0;
30b15541
UW
3760 /* In the first pass of the loop, we only accept functions matching
3761 context_type. If none are found, we add a second pass of the loop
3762 where every function is accepted. */
3763 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3764 {
3765 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3766 {
d12307c1 3767 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3768
d12307c1 3769 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3770 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3771 {
3772 syms[m] = syms[k];
3773 m += 1;
3774 }
3775 }
14f9c5c9
AS
3776 }
3777
dc5c8746
PMR
3778 /* If we got multiple matches, ask the user which one to use. Don't do this
3779 interactive thing during completion, though, as the purpose of the
3780 completion is providing a list of all possible matches. Prompting the
3781 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3782 if (m == 0)
3783 return -1;
dc5c8746 3784 else if (m > 1 && !parse_completion)
14f9c5c9 3785 {
323e0a4a 3786 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3787 user_select_syms (syms, m, 1);
14f9c5c9
AS
3788 return 0;
3789 }
3790 return 0;
3791}
3792
4c4b4cd2
PH
3793/* Returns true (non-zero) iff decoded name N0 should appear before N1
3794 in a listing of choices during disambiguation (see sort_choices, below).
3795 The idea is that overloadings of a subprogram name from the
3796 same package should sort in their source order. We settle for ordering
3797 such symbols by their trailing number (__N or $N). */
3798
14f9c5c9 3799static int
0d5cff50 3800encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3801{
3802 if (N1 == NULL)
3803 return 0;
3804 else if (N0 == NULL)
3805 return 1;
3806 else
3807 {
3808 int k0, k1;
5b4ee69b 3809
d2e4a39e 3810 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3811 ;
d2e4a39e 3812 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3813 ;
d2e4a39e 3814 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3815 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3816 {
3817 int n0, n1;
5b4ee69b 3818
4c4b4cd2
PH
3819 n0 = k0;
3820 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3821 n0 -= 1;
3822 n1 = k1;
3823 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3824 n1 -= 1;
3825 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3826 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3827 }
14f9c5c9
AS
3828 return (strcmp (N0, N1) < 0);
3829 }
3830}
d2e4a39e 3831
4c4b4cd2
PH
3832/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3833 encoded names. */
3834
d2e4a39e 3835static void
d12307c1 3836sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3837{
4c4b4cd2 3838 int i;
5b4ee69b 3839
d2e4a39e 3840 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3841 {
d12307c1 3842 struct block_symbol sym = syms[i];
14f9c5c9
AS
3843 int j;
3844
d2e4a39e 3845 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3846 {
d12307c1
PMR
3847 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3848 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3849 break;
3850 syms[j + 1] = syms[j];
3851 }
d2e4a39e 3852 syms[j + 1] = sym;
14f9c5c9
AS
3853 }
3854}
3855
d72413e6
PMR
3856/* Whether GDB should display formals and return types for functions in the
3857 overloads selection menu. */
3858static int print_signatures = 1;
3859
3860/* Print the signature for SYM on STREAM according to the FLAGS options. For
3861 all but functions, the signature is just the name of the symbol. For
3862 functions, this is the name of the function, the list of types for formals
3863 and the return type (if any). */
3864
3865static void
3866ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3867 const struct type_print_options *flags)
3868{
3869 struct type *type = SYMBOL_TYPE (sym);
3870
3871 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3872 if (!print_signatures
3873 || type == NULL
3874 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3875 return;
3876
3877 if (TYPE_NFIELDS (type) > 0)
3878 {
3879 int i;
3880
3881 fprintf_filtered (stream, " (");
3882 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3883 {
3884 if (i > 0)
3885 fprintf_filtered (stream, "; ");
3886 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3887 flags);
3888 }
3889 fprintf_filtered (stream, ")");
3890 }
3891 if (TYPE_TARGET_TYPE (type) != NULL
3892 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3893 {
3894 fprintf_filtered (stream, " return ");
3895 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3896 }
3897}
3898
4c4b4cd2
PH
3899/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3900 by asking the user (if necessary), returning the number selected,
3901 and setting the first elements of SYMS items. Error if no symbols
3902 selected. */
14f9c5c9
AS
3903
3904/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3905 to be re-integrated one of these days. */
14f9c5c9
AS
3906
3907int
d12307c1 3908user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3909{
3910 int i;
8d749320 3911 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3912 int n_chosen;
3913 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3914 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3915
3916 if (max_results < 1)
323e0a4a 3917 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3918 if (nsyms <= 1)
3919 return nsyms;
3920
717d2f5a
JB
3921 if (select_mode == multiple_symbols_cancel)
3922 error (_("\
3923canceled because the command is ambiguous\n\
3924See set/show multiple-symbol."));
3925
3926 /* If select_mode is "all", then return all possible symbols.
3927 Only do that if more than one symbol can be selected, of course.
3928 Otherwise, display the menu as usual. */
3929 if (select_mode == multiple_symbols_all && max_results > 1)
3930 return nsyms;
3931
323e0a4a 3932 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3933 if (max_results > 1)
323e0a4a 3934 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3935
4c4b4cd2 3936 sort_choices (syms, nsyms);
14f9c5c9
AS
3937
3938 for (i = 0; i < nsyms; i += 1)
3939 {
d12307c1 3940 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3941 continue;
3942
d12307c1 3943 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3944 {
76a01679 3945 struct symtab_and_line sal =
d12307c1 3946 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3947
d72413e6
PMR
3948 printf_unfiltered ("[%d] ", i + first_choice);
3949 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3950 &type_print_raw_options);
323e0a4a 3951 if (sal.symtab == NULL)
d72413e6 3952 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3953 sal.line);
3954 else
d72413e6 3955 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3956 symtab_to_filename_for_display (sal.symtab),
3957 sal.line);
4c4b4cd2
PH
3958 continue;
3959 }
d2e4a39e 3960 else
4c4b4cd2
PH
3961 {
3962 int is_enumeral =
d12307c1
PMR
3963 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3964 && SYMBOL_TYPE (syms[i].symbol) != NULL
3965 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3966 struct symtab *symtab = NULL;
3967
d12307c1
PMR
3968 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3969 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3970
d12307c1 3971 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3972 {
3973 printf_unfiltered ("[%d] ", i + first_choice);
3974 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3975 &type_print_raw_options);
3976 printf_unfiltered (_(" at %s:%d\n"),
3977 symtab_to_filename_for_display (symtab),
3978 SYMBOL_LINE (syms[i].symbol));
3979 }
76a01679 3980 else if (is_enumeral
d12307c1 3981 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3982 {
a3f17187 3983 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3984 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3985 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3986 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3987 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3988 }
d72413e6
PMR
3989 else
3990 {
3991 printf_unfiltered ("[%d] ", i + first_choice);
3992 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3993 &type_print_raw_options);
3994
3995 if (symtab != NULL)
3996 printf_unfiltered (is_enumeral
3997 ? _(" in %s (enumeral)\n")
3998 : _(" at %s:?\n"),
3999 symtab_to_filename_for_display (symtab));
4000 else
4001 printf_unfiltered (is_enumeral
4002 ? _(" (enumeral)\n")
4003 : _(" at ?\n"));
4004 }
4c4b4cd2 4005 }
14f9c5c9 4006 }
d2e4a39e 4007
14f9c5c9 4008 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4009 "overload-choice");
14f9c5c9
AS
4010
4011 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4012 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4013
4014 return n_chosen;
4015}
4016
4017/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4018 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4019 order in CHOICES[0 .. N-1], and return N.
4020
4021 The user types choices as a sequence of numbers on one line
4022 separated by blanks, encoding them as follows:
4023
4c4b4cd2 4024 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4025 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4026 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4027
4c4b4cd2 4028 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4029
4030 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4031 prompts (for use with the -f switch). */
14f9c5c9
AS
4032
4033int
d2e4a39e 4034get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4035 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4036{
d2e4a39e 4037 char *args;
a121b7c1 4038 const char *prompt;
14f9c5c9
AS
4039 int n_chosen;
4040 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4041
14f9c5c9
AS
4042 prompt = getenv ("PS2");
4043 if (prompt == NULL)
0bcd0149 4044 prompt = "> ";
14f9c5c9 4045
89fbedf3 4046 args = command_line_input (prompt, annotation_suffix);
d2e4a39e 4047
14f9c5c9 4048 if (args == NULL)
323e0a4a 4049 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4050
4051 n_chosen = 0;
76a01679 4052
4c4b4cd2
PH
4053 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4054 order, as given in args. Choices are validated. */
14f9c5c9
AS
4055 while (1)
4056 {
d2e4a39e 4057 char *args2;
14f9c5c9
AS
4058 int choice, j;
4059
0fcd72ba 4060 args = skip_spaces (args);
14f9c5c9 4061 if (*args == '\0' && n_chosen == 0)
323e0a4a 4062 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4063 else if (*args == '\0')
4c4b4cd2 4064 break;
14f9c5c9
AS
4065
4066 choice = strtol (args, &args2, 10);
d2e4a39e 4067 if (args == args2 || choice < 0
4c4b4cd2 4068 || choice > n_choices + first_choice - 1)
323e0a4a 4069 error (_("Argument must be choice number"));
14f9c5c9
AS
4070 args = args2;
4071
d2e4a39e 4072 if (choice == 0)
323e0a4a 4073 error (_("cancelled"));
14f9c5c9
AS
4074
4075 if (choice < first_choice)
4c4b4cd2
PH
4076 {
4077 n_chosen = n_choices;
4078 for (j = 0; j < n_choices; j += 1)
4079 choices[j] = j;
4080 break;
4081 }
14f9c5c9
AS
4082 choice -= first_choice;
4083
d2e4a39e 4084 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4085 {
4086 }
14f9c5c9
AS
4087
4088 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4089 {
4090 int k;
5b4ee69b 4091
4c4b4cd2
PH
4092 for (k = n_chosen - 1; k > j; k -= 1)
4093 choices[k + 1] = choices[k];
4094 choices[j + 1] = choice;
4095 n_chosen += 1;
4096 }
14f9c5c9
AS
4097 }
4098
4099 if (n_chosen > max_results)
323e0a4a 4100 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4101
14f9c5c9
AS
4102 return n_chosen;
4103}
4104
4c4b4cd2
PH
4105/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4106 on the function identified by SYM and BLOCK, and taking NARGS
4107 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4108
4109static void
e9d9f57e 4110replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4111 int oplen, struct symbol *sym,
270140bd 4112 const struct block *block)
14f9c5c9
AS
4113{
4114 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4115 symbol, -oplen for operator being replaced). */
d2e4a39e 4116 struct expression *newexp = (struct expression *)
8c1a34e7 4117 xzalloc (sizeof (struct expression)
4c4b4cd2 4118 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4119 struct expression *exp = expp->get ();
14f9c5c9
AS
4120
4121 newexp->nelts = exp->nelts + 7 - oplen;
4122 newexp->language_defn = exp->language_defn;
3489610d 4123 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4124 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4125 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4126 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4127
4128 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4129 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4130
4131 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4132 newexp->elts[pc + 4].block = block;
4133 newexp->elts[pc + 5].symbol = sym;
4134
e9d9f57e 4135 expp->reset (newexp);
d2e4a39e 4136}
14f9c5c9
AS
4137
4138/* Type-class predicates */
4139
4c4b4cd2
PH
4140/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4141 or FLOAT). */
14f9c5c9
AS
4142
4143static int
d2e4a39e 4144numeric_type_p (struct type *type)
14f9c5c9
AS
4145{
4146 if (type == NULL)
4147 return 0;
d2e4a39e
AS
4148 else
4149 {
4150 switch (TYPE_CODE (type))
4c4b4cd2
PH
4151 {
4152 case TYPE_CODE_INT:
4153 case TYPE_CODE_FLT:
4154 return 1;
4155 case TYPE_CODE_RANGE:
4156 return (type == TYPE_TARGET_TYPE (type)
4157 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4158 default:
4159 return 0;
4160 }
d2e4a39e 4161 }
14f9c5c9
AS
4162}
4163
4c4b4cd2 4164/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4165
4166static int
d2e4a39e 4167integer_type_p (struct type *type)
14f9c5c9
AS
4168{
4169 if (type == NULL)
4170 return 0;
d2e4a39e
AS
4171 else
4172 {
4173 switch (TYPE_CODE (type))
4c4b4cd2
PH
4174 {
4175 case TYPE_CODE_INT:
4176 return 1;
4177 case TYPE_CODE_RANGE:
4178 return (type == TYPE_TARGET_TYPE (type)
4179 || integer_type_p (TYPE_TARGET_TYPE (type)));
4180 default:
4181 return 0;
4182 }
d2e4a39e 4183 }
14f9c5c9
AS
4184}
4185
4c4b4cd2 4186/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4187
4188static int
d2e4a39e 4189scalar_type_p (struct type *type)
14f9c5c9
AS
4190{
4191 if (type == NULL)
4192 return 0;
d2e4a39e
AS
4193 else
4194 {
4195 switch (TYPE_CODE (type))
4c4b4cd2
PH
4196 {
4197 case TYPE_CODE_INT:
4198 case TYPE_CODE_RANGE:
4199 case TYPE_CODE_ENUM:
4200 case TYPE_CODE_FLT:
4201 return 1;
4202 default:
4203 return 0;
4204 }
d2e4a39e 4205 }
14f9c5c9
AS
4206}
4207
4c4b4cd2 4208/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4209
4210static int
d2e4a39e 4211discrete_type_p (struct type *type)
14f9c5c9
AS
4212{
4213 if (type == NULL)
4214 return 0;
d2e4a39e
AS
4215 else
4216 {
4217 switch (TYPE_CODE (type))
4c4b4cd2
PH
4218 {
4219 case TYPE_CODE_INT:
4220 case TYPE_CODE_RANGE:
4221 case TYPE_CODE_ENUM:
872f0337 4222 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4223 return 1;
4224 default:
4225 return 0;
4226 }
d2e4a39e 4227 }
14f9c5c9
AS
4228}
4229
4c4b4cd2
PH
4230/* Returns non-zero if OP with operands in the vector ARGS could be
4231 a user-defined function. Errs on the side of pre-defined operators
4232 (i.e., result 0). */
14f9c5c9
AS
4233
4234static int
d2e4a39e 4235possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4236{
76a01679 4237 struct type *type0 =
df407dfe 4238 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4239 struct type *type1 =
df407dfe 4240 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4241
4c4b4cd2
PH
4242 if (type0 == NULL)
4243 return 0;
4244
14f9c5c9
AS
4245 switch (op)
4246 {
4247 default:
4248 return 0;
4249
4250 case BINOP_ADD:
4251 case BINOP_SUB:
4252 case BINOP_MUL:
4253 case BINOP_DIV:
d2e4a39e 4254 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4255
4256 case BINOP_REM:
4257 case BINOP_MOD:
4258 case BINOP_BITWISE_AND:
4259 case BINOP_BITWISE_IOR:
4260 case BINOP_BITWISE_XOR:
d2e4a39e 4261 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4262
4263 case BINOP_EQUAL:
4264 case BINOP_NOTEQUAL:
4265 case BINOP_LESS:
4266 case BINOP_GTR:
4267 case BINOP_LEQ:
4268 case BINOP_GEQ:
d2e4a39e 4269 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4270
4271 case BINOP_CONCAT:
ee90b9ab 4272 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4273
4274 case BINOP_EXP:
d2e4a39e 4275 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4276
4277 case UNOP_NEG:
4278 case UNOP_PLUS:
4279 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4280 case UNOP_ABS:
4281 return (!numeric_type_p (type0));
14f9c5c9
AS
4282
4283 }
4284}
4285\f
4c4b4cd2 4286 /* Renaming */
14f9c5c9 4287
aeb5907d
JB
4288/* NOTES:
4289
4290 1. In the following, we assume that a renaming type's name may
4291 have an ___XD suffix. It would be nice if this went away at some
4292 point.
4293 2. We handle both the (old) purely type-based representation of
4294 renamings and the (new) variable-based encoding. At some point,
4295 it is devoutly to be hoped that the former goes away
4296 (FIXME: hilfinger-2007-07-09).
4297 3. Subprogram renamings are not implemented, although the XRS
4298 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4299
4300/* If SYM encodes a renaming,
4301
4302 <renaming> renames <renamed entity>,
4303
4304 sets *LEN to the length of the renamed entity's name,
4305 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4306 the string describing the subcomponent selected from the renamed
0963b4bd 4307 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4308 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4309 are undefined). Otherwise, returns a value indicating the category
4310 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4311 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4312 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4313 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4314 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4315 may be NULL, in which case they are not assigned.
4316
4317 [Currently, however, GCC does not generate subprogram renamings.] */
4318
4319enum ada_renaming_category
4320ada_parse_renaming (struct symbol *sym,
4321 const char **renamed_entity, int *len,
4322 const char **renaming_expr)
4323{
4324 enum ada_renaming_category kind;
4325 const char *info;
4326 const char *suffix;
4327
4328 if (sym == NULL)
4329 return ADA_NOT_RENAMING;
4330 switch (SYMBOL_CLASS (sym))
14f9c5c9 4331 {
aeb5907d
JB
4332 default:
4333 return ADA_NOT_RENAMING;
4334 case LOC_TYPEDEF:
4335 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4336 renamed_entity, len, renaming_expr);
4337 case LOC_LOCAL:
4338 case LOC_STATIC:
4339 case LOC_COMPUTED:
4340 case LOC_OPTIMIZED_OUT:
4341 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4342 if (info == NULL)
4343 return ADA_NOT_RENAMING;
4344 switch (info[5])
4345 {
4346 case '_':
4347 kind = ADA_OBJECT_RENAMING;
4348 info += 6;
4349 break;
4350 case 'E':
4351 kind = ADA_EXCEPTION_RENAMING;
4352 info += 7;
4353 break;
4354 case 'P':
4355 kind = ADA_PACKAGE_RENAMING;
4356 info += 7;
4357 break;
4358 case 'S':
4359 kind = ADA_SUBPROGRAM_RENAMING;
4360 info += 7;
4361 break;
4362 default:
4363 return ADA_NOT_RENAMING;
4364 }
14f9c5c9 4365 }
4c4b4cd2 4366
aeb5907d
JB
4367 if (renamed_entity != NULL)
4368 *renamed_entity = info;
4369 suffix = strstr (info, "___XE");
4370 if (suffix == NULL || suffix == info)
4371 return ADA_NOT_RENAMING;
4372 if (len != NULL)
4373 *len = strlen (info) - strlen (suffix);
4374 suffix += 5;
4375 if (renaming_expr != NULL)
4376 *renaming_expr = suffix;
4377 return kind;
4378}
4379
4380/* Assuming TYPE encodes a renaming according to the old encoding in
4381 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4382 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4383 ADA_NOT_RENAMING otherwise. */
4384static enum ada_renaming_category
4385parse_old_style_renaming (struct type *type,
4386 const char **renamed_entity, int *len,
4387 const char **renaming_expr)
4388{
4389 enum ada_renaming_category kind;
4390 const char *name;
4391 const char *info;
4392 const char *suffix;
14f9c5c9 4393
aeb5907d
JB
4394 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4395 || TYPE_NFIELDS (type) != 1)
4396 return ADA_NOT_RENAMING;
14f9c5c9 4397
a737d952 4398 name = TYPE_NAME (type);
aeb5907d
JB
4399 if (name == NULL)
4400 return ADA_NOT_RENAMING;
4401
4402 name = strstr (name, "___XR");
4403 if (name == NULL)
4404 return ADA_NOT_RENAMING;
4405 switch (name[5])
4406 {
4407 case '\0':
4408 case '_':
4409 kind = ADA_OBJECT_RENAMING;
4410 break;
4411 case 'E':
4412 kind = ADA_EXCEPTION_RENAMING;
4413 break;
4414 case 'P':
4415 kind = ADA_PACKAGE_RENAMING;
4416 break;
4417 case 'S':
4418 kind = ADA_SUBPROGRAM_RENAMING;
4419 break;
4420 default:
4421 return ADA_NOT_RENAMING;
4422 }
14f9c5c9 4423
aeb5907d
JB
4424 info = TYPE_FIELD_NAME (type, 0);
4425 if (info == NULL)
4426 return ADA_NOT_RENAMING;
4427 if (renamed_entity != NULL)
4428 *renamed_entity = info;
4429 suffix = strstr (info, "___XE");
4430 if (renaming_expr != NULL)
4431 *renaming_expr = suffix + 5;
4432 if (suffix == NULL || suffix == info)
4433 return ADA_NOT_RENAMING;
4434 if (len != NULL)
4435 *len = suffix - info;
4436 return kind;
a5ee536b
JB
4437}
4438
4439/* Compute the value of the given RENAMING_SYM, which is expected to
4440 be a symbol encoding a renaming expression. BLOCK is the block
4441 used to evaluate the renaming. */
52ce6436 4442
a5ee536b
JB
4443static struct value *
4444ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4445 const struct block *block)
a5ee536b 4446{
bbc13ae3 4447 const char *sym_name;
a5ee536b 4448
bbc13ae3 4449 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4450 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4451 return evaluate_expression (expr.get ());
a5ee536b 4452}
14f9c5c9 4453\f
d2e4a39e 4454
4c4b4cd2 4455 /* Evaluation: Function Calls */
14f9c5c9 4456
4c4b4cd2 4457/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4458 lvalues, and otherwise has the side-effect of allocating memory
4459 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4460
d2e4a39e 4461static struct value *
40bc484c 4462ensure_lval (struct value *val)
14f9c5c9 4463{
40bc484c
JB
4464 if (VALUE_LVAL (val) == not_lval
4465 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4466 {
df407dfe 4467 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4468 const CORE_ADDR addr =
4469 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4470
a84a8a0d 4471 VALUE_LVAL (val) = lval_memory;
1a088441 4472 set_value_address (val, addr);
40bc484c 4473 write_memory (addr, value_contents (val), len);
c3e5cd34 4474 }
14f9c5c9
AS
4475
4476 return val;
4477}
4478
4479/* Return the value ACTUAL, converted to be an appropriate value for a
4480 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4481 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4482 values not residing in memory, updating it as needed. */
14f9c5c9 4483
a93c0eb6 4484struct value *
40bc484c 4485ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4486{
df407dfe 4487 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4488 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4489 struct type *formal_target =
4490 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4491 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4492 struct type *actual_target =
4493 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4494 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4495
4c4b4cd2 4496 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4497 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4498 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4499 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4500 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4501 {
a84a8a0d 4502 struct value *result;
5b4ee69b 4503
14f9c5c9 4504 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4505 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4506 result = desc_data (actual);
cb923fcc 4507 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4508 {
4509 if (VALUE_LVAL (actual) != lval_memory)
4510 {
4511 struct value *val;
5b4ee69b 4512
df407dfe 4513 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4514 val = allocate_value (actual_type);
990a07ab 4515 memcpy ((char *) value_contents_raw (val),
0fd88904 4516 (char *) value_contents (actual),
4c4b4cd2 4517 TYPE_LENGTH (actual_type));
40bc484c 4518 actual = ensure_lval (val);
4c4b4cd2 4519 }
a84a8a0d 4520 result = value_addr (actual);
4c4b4cd2 4521 }
a84a8a0d
JB
4522 else
4523 return actual;
b1af9e97 4524 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4525 }
4526 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4527 return ada_value_ind (actual);
8344af1e
JB
4528 else if (ada_is_aligner_type (formal_type))
4529 {
4530 /* We need to turn this parameter into an aligner type
4531 as well. */
4532 struct value *aligner = allocate_value (formal_type);
4533 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4534
4535 value_assign_to_component (aligner, component, actual);
4536 return aligner;
4537 }
14f9c5c9
AS
4538
4539 return actual;
4540}
4541
438c98a1
JB
4542/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4543 type TYPE. This is usually an inefficient no-op except on some targets
4544 (such as AVR) where the representation of a pointer and an address
4545 differs. */
4546
4547static CORE_ADDR
4548value_pointer (struct value *value, struct type *type)
4549{
4550 struct gdbarch *gdbarch = get_type_arch (type);
4551 unsigned len = TYPE_LENGTH (type);
224c3ddb 4552 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4553 CORE_ADDR addr;
4554
4555 addr = value_address (value);
4556 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4557 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4558 return addr;
4559}
4560
14f9c5c9 4561
4c4b4cd2
PH
4562/* Push a descriptor of type TYPE for array value ARR on the stack at
4563 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4564 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4565 to-descriptor type rather than a descriptor type), a struct value *
4566 representing a pointer to this descriptor. */
14f9c5c9 4567
d2e4a39e 4568static struct value *
40bc484c 4569make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4570{
d2e4a39e
AS
4571 struct type *bounds_type = desc_bounds_type (type);
4572 struct type *desc_type = desc_base_type (type);
4573 struct value *descriptor = allocate_value (desc_type);
4574 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4575 int i;
d2e4a39e 4576
0963b4bd
MS
4577 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4578 i > 0; i -= 1)
14f9c5c9 4579 {
19f220c3
JK
4580 modify_field (value_type (bounds), value_contents_writeable (bounds),
4581 ada_array_bound (arr, i, 0),
4582 desc_bound_bitpos (bounds_type, i, 0),
4583 desc_bound_bitsize (bounds_type, i, 0));
4584 modify_field (value_type (bounds), value_contents_writeable (bounds),
4585 ada_array_bound (arr, i, 1),
4586 desc_bound_bitpos (bounds_type, i, 1),
4587 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4588 }
d2e4a39e 4589
40bc484c 4590 bounds = ensure_lval (bounds);
d2e4a39e 4591
19f220c3
JK
4592 modify_field (value_type (descriptor),
4593 value_contents_writeable (descriptor),
4594 value_pointer (ensure_lval (arr),
4595 TYPE_FIELD_TYPE (desc_type, 0)),
4596 fat_pntr_data_bitpos (desc_type),
4597 fat_pntr_data_bitsize (desc_type));
4598
4599 modify_field (value_type (descriptor),
4600 value_contents_writeable (descriptor),
4601 value_pointer (bounds,
4602 TYPE_FIELD_TYPE (desc_type, 1)),
4603 fat_pntr_bounds_bitpos (desc_type),
4604 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4605
40bc484c 4606 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4607
4608 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4609 return value_addr (descriptor);
4610 else
4611 return descriptor;
4612}
14f9c5c9 4613\f
3d9434b5
JB
4614 /* Symbol Cache Module */
4615
3d9434b5 4616/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4617 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4618 on the type of entity being printed, the cache can make it as much
4619 as an order of magnitude faster than without it.
4620
4621 The descriptive type DWARF extension has significantly reduced
4622 the need for this cache, at least when DWARF is being used. However,
4623 even in this case, some expensive name-based symbol searches are still
4624 sometimes necessary - to find an XVZ variable, mostly. */
4625
ee01b665 4626/* Initialize the contents of SYM_CACHE. */
3d9434b5 4627
ee01b665
JB
4628static void
4629ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4630{
4631 obstack_init (&sym_cache->cache_space);
4632 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4633}
3d9434b5 4634
ee01b665
JB
4635/* Free the memory used by SYM_CACHE. */
4636
4637static void
4638ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4639{
ee01b665
JB
4640 obstack_free (&sym_cache->cache_space, NULL);
4641 xfree (sym_cache);
4642}
3d9434b5 4643
ee01b665
JB
4644/* Return the symbol cache associated to the given program space PSPACE.
4645 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4646
ee01b665
JB
4647static struct ada_symbol_cache *
4648ada_get_symbol_cache (struct program_space *pspace)
4649{
4650 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4651
66c168ae 4652 if (pspace_data->sym_cache == NULL)
ee01b665 4653 {
66c168ae
JB
4654 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4655 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4656 }
4657
66c168ae 4658 return pspace_data->sym_cache;
ee01b665 4659}
3d9434b5
JB
4660
4661/* Clear all entries from the symbol cache. */
4662
4663static void
4664ada_clear_symbol_cache (void)
4665{
ee01b665
JB
4666 struct ada_symbol_cache *sym_cache
4667 = ada_get_symbol_cache (current_program_space);
4668
4669 obstack_free (&sym_cache->cache_space, NULL);
4670 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4671}
4672
fe978cb0 4673/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4674 Return it if found, or NULL otherwise. */
4675
4676static struct cache_entry **
fe978cb0 4677find_entry (const char *name, domain_enum domain)
3d9434b5 4678{
ee01b665
JB
4679 struct ada_symbol_cache *sym_cache
4680 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4681 int h = msymbol_hash (name) % HASH_SIZE;
4682 struct cache_entry **e;
4683
ee01b665 4684 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4685 {
fe978cb0 4686 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4687 return e;
4688 }
4689 return NULL;
4690}
4691
fe978cb0 4692/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4693 Return 1 if found, 0 otherwise.
4694
4695 If an entry was found and SYM is not NULL, set *SYM to the entry's
4696 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4697
96d887e8 4698static int
fe978cb0 4699lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4700 struct symbol **sym, const struct block **block)
96d887e8 4701{
fe978cb0 4702 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4703
4704 if (e == NULL)
4705 return 0;
4706 if (sym != NULL)
4707 *sym = (*e)->sym;
4708 if (block != NULL)
4709 *block = (*e)->block;
4710 return 1;
96d887e8
PH
4711}
4712
3d9434b5 4713/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4714 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4715
96d887e8 4716static void
fe978cb0 4717cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4718 const struct block *block)
96d887e8 4719{
ee01b665
JB
4720 struct ada_symbol_cache *sym_cache
4721 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4722 int h;
4723 char *copy;
4724 struct cache_entry *e;
4725
1994afbf
DE
4726 /* Symbols for builtin types don't have a block.
4727 For now don't cache such symbols. */
4728 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4729 return;
4730
3d9434b5
JB
4731 /* If the symbol is a local symbol, then do not cache it, as a search
4732 for that symbol depends on the context. To determine whether
4733 the symbol is local or not, we check the block where we found it
4734 against the global and static blocks of its associated symtab. */
4735 if (sym
08be3fe3 4736 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4737 GLOBAL_BLOCK) != block
08be3fe3 4738 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4739 STATIC_BLOCK) != block)
3d9434b5
JB
4740 return;
4741
4742 h = msymbol_hash (name) % HASH_SIZE;
e39db4db 4743 e = XOBNEW (&sym_cache->cache_space, cache_entry);
ee01b665
JB
4744 e->next = sym_cache->root[h];
4745 sym_cache->root[h] = e;
224c3ddb
SM
4746 e->name = copy
4747 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4748 strcpy (copy, name);
4749 e->sym = sym;
fe978cb0 4750 e->domain = domain;
3d9434b5 4751 e->block = block;
96d887e8 4752}
4c4b4cd2
PH
4753\f
4754 /* Symbol Lookup */
4755
b5ec771e
PA
4756/* Return the symbol name match type that should be used used when
4757 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4758
4759 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4760 for Ada lookups. */
c0431670 4761
b5ec771e
PA
4762static symbol_name_match_type
4763name_match_type_from_name (const char *lookup_name)
c0431670 4764{
b5ec771e
PA
4765 return (strstr (lookup_name, "__") == NULL
4766 ? symbol_name_match_type::WILD
4767 : symbol_name_match_type::FULL);
c0431670
JB
4768}
4769
4c4b4cd2
PH
4770/* Return the result of a standard (literal, C-like) lookup of NAME in
4771 given DOMAIN, visible from lexical block BLOCK. */
4772
4773static struct symbol *
4774standard_lookup (const char *name, const struct block *block,
4775 domain_enum domain)
4776{
acbd605d 4777 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4778 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4779
d12307c1
PMR
4780 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4781 return sym.symbol;
2570f2b7 4782 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4783 cache_symbol (name, domain, sym.symbol, sym.block);
4784 return sym.symbol;
4c4b4cd2
PH
4785}
4786
4787
4788/* Non-zero iff there is at least one non-function/non-enumeral symbol
4789 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4790 since they contend in overloading in the same way. */
4791static int
d12307c1 4792is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4793{
4794 int i;
4795
4796 for (i = 0; i < n; i += 1)
d12307c1
PMR
4797 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4798 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4799 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4800 return 1;
4801
4802 return 0;
4803}
4804
4805/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4806 struct types. Otherwise, they may not. */
14f9c5c9
AS
4807
4808static int
d2e4a39e 4809equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4810{
d2e4a39e 4811 if (type0 == type1)
14f9c5c9 4812 return 1;
d2e4a39e 4813 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4814 || TYPE_CODE (type0) != TYPE_CODE (type1))
4815 return 0;
d2e4a39e 4816 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4817 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4818 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4819 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4820 return 1;
d2e4a39e 4821
14f9c5c9
AS
4822 return 0;
4823}
4824
4825/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4826 no more defined than that of SYM1. */
14f9c5c9
AS
4827
4828static int
d2e4a39e 4829lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4830{
4831 if (sym0 == sym1)
4832 return 1;
176620f1 4833 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4834 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4835 return 0;
4836
d2e4a39e 4837 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4838 {
4839 case LOC_UNDEF:
4840 return 1;
4841 case LOC_TYPEDEF:
4842 {
4c4b4cd2
PH
4843 struct type *type0 = SYMBOL_TYPE (sym0);
4844 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4845 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4846 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4847 int len0 = strlen (name0);
5b4ee69b 4848
4c4b4cd2
PH
4849 return
4850 TYPE_CODE (type0) == TYPE_CODE (type1)
4851 && (equiv_types (type0, type1)
4852 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4853 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4854 }
4855 case LOC_CONST:
4856 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4857 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4858 default:
4859 return 0;
14f9c5c9
AS
4860 }
4861}
4862
d12307c1 4863/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4864 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4865
4866static void
76a01679
JB
4867add_defn_to_vec (struct obstack *obstackp,
4868 struct symbol *sym,
f0c5f9b2 4869 const struct block *block)
14f9c5c9
AS
4870{
4871 int i;
d12307c1 4872 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4873
529cad9c
PH
4874 /* Do not try to complete stub types, as the debugger is probably
4875 already scanning all symbols matching a certain name at the
4876 time when this function is called. Trying to replace the stub
4877 type by its associated full type will cause us to restart a scan
4878 which may lead to an infinite recursion. Instead, the client
4879 collecting the matching symbols will end up collecting several
4880 matches, with at least one of them complete. It can then filter
4881 out the stub ones if needed. */
4882
4c4b4cd2
PH
4883 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4884 {
d12307c1 4885 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4886 return;
d12307c1 4887 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4888 {
d12307c1 4889 prevDefns[i].symbol = sym;
4c4b4cd2 4890 prevDefns[i].block = block;
4c4b4cd2 4891 return;
76a01679 4892 }
4c4b4cd2
PH
4893 }
4894
4895 {
d12307c1 4896 struct block_symbol info;
4c4b4cd2 4897
d12307c1 4898 info.symbol = sym;
4c4b4cd2 4899 info.block = block;
d12307c1 4900 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4901 }
4902}
4903
d12307c1
PMR
4904/* Number of block_symbol structures currently collected in current vector in
4905 OBSTACKP. */
4c4b4cd2 4906
76a01679
JB
4907static int
4908num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4909{
d12307c1 4910 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4911}
4912
d12307c1
PMR
4913/* Vector of block_symbol structures currently collected in current vector in
4914 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4915
d12307c1 4916static struct block_symbol *
4c4b4cd2
PH
4917defns_collected (struct obstack *obstackp, int finish)
4918{
4919 if (finish)
224c3ddb 4920 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4921 else
d12307c1 4922 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4923}
4924
7c7b6655
TT
4925/* Return a bound minimal symbol matching NAME according to Ada
4926 decoding rules. Returns an invalid symbol if there is no such
4927 minimal symbol. Names prefixed with "standard__" are handled
4928 specially: "standard__" is first stripped off, and only static and
4929 global symbols are searched. */
4c4b4cd2 4930
7c7b6655 4931struct bound_minimal_symbol
96d887e8 4932ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4933{
7c7b6655 4934 struct bound_minimal_symbol result;
4c4b4cd2 4935 struct objfile *objfile;
96d887e8 4936 struct minimal_symbol *msymbol;
4c4b4cd2 4937
7c7b6655
TT
4938 memset (&result, 0, sizeof (result));
4939
b5ec771e
PA
4940 symbol_name_match_type match_type = name_match_type_from_name (name);
4941 lookup_name_info lookup_name (name, match_type);
4942
4943 symbol_name_matcher_ftype *match_name
4944 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4945
96d887e8
PH
4946 ALL_MSYMBOLS (objfile, msymbol)
4947 {
b5ec771e 4948 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
96d887e8 4949 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4950 {
4951 result.minsym = msymbol;
4952 result.objfile = objfile;
4953 break;
4954 }
96d887e8 4955 }
4c4b4cd2 4956
7c7b6655 4957 return result;
96d887e8 4958}
4c4b4cd2 4959
96d887e8
PH
4960/* For all subprograms that statically enclose the subprogram of the
4961 selected frame, add symbols matching identifier NAME in DOMAIN
4962 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4963 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4964 with a wildcard prefix. */
4c4b4cd2 4965
96d887e8
PH
4966static void
4967add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4968 const lookup_name_info &lookup_name,
4969 domain_enum domain)
96d887e8 4970{
96d887e8 4971}
14f9c5c9 4972
96d887e8
PH
4973/* True if TYPE is definitely an artificial type supplied to a symbol
4974 for which no debugging information was given in the symbol file. */
14f9c5c9 4975
96d887e8
PH
4976static int
4977is_nondebugging_type (struct type *type)
4978{
0d5cff50 4979 const char *name = ada_type_name (type);
5b4ee69b 4980
96d887e8
PH
4981 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4982}
4c4b4cd2 4983
8f17729f
JB
4984/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4985 that are deemed "identical" for practical purposes.
4986
4987 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4988 types and that their number of enumerals is identical (in other
4989 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4990
4991static int
4992ada_identical_enum_types_p (struct type *type1, struct type *type2)
4993{
4994 int i;
4995
4996 /* The heuristic we use here is fairly conservative. We consider
4997 that 2 enumerate types are identical if they have the same
4998 number of enumerals and that all enumerals have the same
4999 underlying value and name. */
5000
5001 /* All enums in the type should have an identical underlying value. */
5002 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 5003 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
5004 return 0;
5005
5006 /* All enumerals should also have the same name (modulo any numerical
5007 suffix). */
5008 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5009 {
0d5cff50
DE
5010 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5011 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5012 int len_1 = strlen (name_1);
5013 int len_2 = strlen (name_2);
5014
5015 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5016 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5017 if (len_1 != len_2
5018 || strncmp (TYPE_FIELD_NAME (type1, i),
5019 TYPE_FIELD_NAME (type2, i),
5020 len_1) != 0)
5021 return 0;
5022 }
5023
5024 return 1;
5025}
5026
5027/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5028 that are deemed "identical" for practical purposes. Sometimes,
5029 enumerals are not strictly identical, but their types are so similar
5030 that they can be considered identical.
5031
5032 For instance, consider the following code:
5033
5034 type Color is (Black, Red, Green, Blue, White);
5035 type RGB_Color is new Color range Red .. Blue;
5036
5037 Type RGB_Color is a subrange of an implicit type which is a copy
5038 of type Color. If we call that implicit type RGB_ColorB ("B" is
5039 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5040 As a result, when an expression references any of the enumeral
5041 by name (Eg. "print green"), the expression is technically
5042 ambiguous and the user should be asked to disambiguate. But
5043 doing so would only hinder the user, since it wouldn't matter
5044 what choice he makes, the outcome would always be the same.
5045 So, for practical purposes, we consider them as the same. */
5046
5047static int
54d343a2 5048symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
5049{
5050 int i;
5051
5052 /* Before performing a thorough comparison check of each type,
5053 we perform a series of inexpensive checks. We expect that these
5054 checks will quickly fail in the vast majority of cases, and thus
5055 help prevent the unnecessary use of a more expensive comparison.
5056 Said comparison also expects us to make some of these checks
5057 (see ada_identical_enum_types_p). */
5058
5059 /* Quick check: All symbols should have an enum type. */
54d343a2 5060 for (i = 0; i < syms.size (); i++)
d12307c1 5061 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5062 return 0;
5063
5064 /* Quick check: They should all have the same value. */
54d343a2 5065 for (i = 1; i < syms.size (); i++)
d12307c1 5066 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5067 return 0;
5068
5069 /* Quick check: They should all have the same number of enumerals. */
54d343a2 5070 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5071 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5072 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5073 return 0;
5074
5075 /* All the sanity checks passed, so we might have a set of
5076 identical enumeration types. Perform a more complete
5077 comparison of the type of each symbol. */
54d343a2 5078 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5079 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5080 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5081 return 0;
5082
5083 return 1;
5084}
5085
54d343a2 5086/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
5087 duplicate other symbols in the list (The only case I know of where
5088 this happens is when object files containing stabs-in-ecoff are
5089 linked with files containing ordinary ecoff debugging symbols (or no
5090 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5091 Returns the number of items in the modified list. */
4c4b4cd2 5092
96d887e8 5093static int
54d343a2 5094remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5095{
5096 int i, j;
4c4b4cd2 5097
8f17729f
JB
5098 /* We should never be called with less than 2 symbols, as there
5099 cannot be any extra symbol in that case. But it's easy to
5100 handle, since we have nothing to do in that case. */
54d343a2
TT
5101 if (syms->size () < 2)
5102 return syms->size ();
8f17729f 5103
96d887e8 5104 i = 0;
54d343a2 5105 while (i < syms->size ())
96d887e8 5106 {
a35ddb44 5107 int remove_p = 0;
339c13b6
JB
5108
5109 /* If two symbols have the same name and one of them is a stub type,
5110 the get rid of the stub. */
5111
54d343a2
TT
5112 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5113 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5114 {
54d343a2 5115 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5116 {
5117 if (j != i
54d343a2
TT
5118 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5119 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5120 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5121 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5122 remove_p = 1;
339c13b6
JB
5123 }
5124 }
5125
5126 /* Two symbols with the same name, same class and same address
5127 should be identical. */
5128
54d343a2
TT
5129 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5130 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5131 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5132 {
54d343a2 5133 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5134 {
5135 if (i != j
54d343a2
TT
5136 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5137 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5138 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5139 && SYMBOL_CLASS ((*syms)[i].symbol)
5140 == SYMBOL_CLASS ((*syms)[j].symbol)
5141 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5142 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5143 remove_p = 1;
4c4b4cd2 5144 }
4c4b4cd2 5145 }
339c13b6 5146
a35ddb44 5147 if (remove_p)
54d343a2 5148 syms->erase (syms->begin () + i);
339c13b6 5149
96d887e8 5150 i += 1;
14f9c5c9 5151 }
8f17729f
JB
5152
5153 /* If all the remaining symbols are identical enumerals, then
5154 just keep the first one and discard the rest.
5155
5156 Unlike what we did previously, we do not discard any entry
5157 unless they are ALL identical. This is because the symbol
5158 comparison is not a strict comparison, but rather a practical
5159 comparison. If all symbols are considered identical, then
5160 we can just go ahead and use the first one and discard the rest.
5161 But if we cannot reduce the list to a single element, we have
5162 to ask the user to disambiguate anyways. And if we have to
5163 present a multiple-choice menu, it's less confusing if the list
5164 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5165 if (symbols_are_identical_enums (*syms))
5166 syms->resize (1);
8f17729f 5167
54d343a2 5168 return syms->size ();
14f9c5c9
AS
5169}
5170
96d887e8
PH
5171/* Given a type that corresponds to a renaming entity, use the type name
5172 to extract the scope (package name or function name, fully qualified,
5173 and following the GNAT encoding convention) where this renaming has been
49d83361 5174 defined. */
4c4b4cd2 5175
49d83361 5176static std::string
96d887e8 5177xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5178{
96d887e8 5179 /* The renaming types adhere to the following convention:
0963b4bd 5180 <scope>__<rename>___<XR extension>.
96d887e8
PH
5181 So, to extract the scope, we search for the "___XR" extension,
5182 and then backtrack until we find the first "__". */
76a01679 5183
a737d952 5184 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5185 const char *suffix = strstr (name, "___XR");
5186 const char *last;
14f9c5c9 5187
96d887e8
PH
5188 /* Now, backtrack a bit until we find the first "__". Start looking
5189 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5190
96d887e8
PH
5191 for (last = suffix - 3; last > name; last--)
5192 if (last[0] == '_' && last[1] == '_')
5193 break;
76a01679 5194
96d887e8 5195 /* Make a copy of scope and return it. */
49d83361 5196 return std::string (name, last);
4c4b4cd2
PH
5197}
5198
96d887e8 5199/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5200
96d887e8
PH
5201static int
5202is_package_name (const char *name)
4c4b4cd2 5203{
96d887e8
PH
5204 /* Here, We take advantage of the fact that no symbols are generated
5205 for packages, while symbols are generated for each function.
5206 So the condition for NAME represent a package becomes equivalent
5207 to NAME not existing in our list of symbols. There is only one
5208 small complication with library-level functions (see below). */
4c4b4cd2 5209
96d887e8
PH
5210 /* If it is a function that has not been defined at library level,
5211 then we should be able to look it up in the symbols. */
5212 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5213 return 0;
14f9c5c9 5214
96d887e8
PH
5215 /* Library-level function names start with "_ada_". See if function
5216 "_ada_" followed by NAME can be found. */
14f9c5c9 5217
96d887e8 5218 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5219 functions names cannot contain "__" in them. */
96d887e8
PH
5220 if (strstr (name, "__") != NULL)
5221 return 0;
4c4b4cd2 5222
528e1572 5223 std::string fun_name = string_printf ("_ada_%s", name);
14f9c5c9 5224
528e1572 5225 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
96d887e8 5226}
14f9c5c9 5227
96d887e8 5228/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5229 not visible from FUNCTION_NAME. */
14f9c5c9 5230
96d887e8 5231static int
0d5cff50 5232old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5233{
aeb5907d
JB
5234 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5235 return 0;
5236
49d83361 5237 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5238
96d887e8 5239 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5240 if (is_package_name (scope.c_str ()))
5241 return 0;
14f9c5c9 5242
96d887e8
PH
5243 /* Check that the rename is in the current function scope by checking
5244 that its name starts with SCOPE. */
76a01679 5245
96d887e8
PH
5246 /* If the function name starts with "_ada_", it means that it is
5247 a library-level function. Strip this prefix before doing the
5248 comparison, as the encoding for the renaming does not contain
5249 this prefix. */
61012eef 5250 if (startswith (function_name, "_ada_"))
96d887e8 5251 function_name += 5;
f26caa11 5252
49d83361 5253 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5254}
5255
aeb5907d
JB
5256/* Remove entries from SYMS that corresponds to a renaming entity that
5257 is not visible from the function associated with CURRENT_BLOCK or
5258 that is superfluous due to the presence of more specific renaming
5259 information. Places surviving symbols in the initial entries of
5260 SYMS and returns the number of surviving symbols.
96d887e8
PH
5261
5262 Rationale:
aeb5907d
JB
5263 First, in cases where an object renaming is implemented as a
5264 reference variable, GNAT may produce both the actual reference
5265 variable and the renaming encoding. In this case, we discard the
5266 latter.
5267
5268 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5269 entity. Unfortunately, STABS currently does not support the definition
5270 of types that are local to a given lexical block, so all renamings types
5271 are emitted at library level. As a consequence, if an application
5272 contains two renaming entities using the same name, and a user tries to
5273 print the value of one of these entities, the result of the ada symbol
5274 lookup will also contain the wrong renaming type.
f26caa11 5275
96d887e8
PH
5276 This function partially covers for this limitation by attempting to
5277 remove from the SYMS list renaming symbols that should be visible
5278 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5279 method with the current information available. The implementation
5280 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5281
5282 - When the user tries to print a rename in a function while there
5283 is another rename entity defined in a package: Normally, the
5284 rename in the function has precedence over the rename in the
5285 package, so the latter should be removed from the list. This is
5286 currently not the case.
5287
5288 - This function will incorrectly remove valid renames if
5289 the CURRENT_BLOCK corresponds to a function which symbol name
5290 has been changed by an "Export" pragma. As a consequence,
5291 the user will be unable to print such rename entities. */
4c4b4cd2 5292
14f9c5c9 5293static int
54d343a2
TT
5294remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5295 const struct block *current_block)
4c4b4cd2
PH
5296{
5297 struct symbol *current_function;
0d5cff50 5298 const char *current_function_name;
4c4b4cd2 5299 int i;
aeb5907d
JB
5300 int is_new_style_renaming;
5301
5302 /* If there is both a renaming foo___XR... encoded as a variable and
5303 a simple variable foo in the same block, discard the latter.
0963b4bd 5304 First, zero out such symbols, then compress. */
aeb5907d 5305 is_new_style_renaming = 0;
54d343a2 5306 for (i = 0; i < syms->size (); i += 1)
aeb5907d 5307 {
54d343a2
TT
5308 struct symbol *sym = (*syms)[i].symbol;
5309 const struct block *block = (*syms)[i].block;
aeb5907d
JB
5310 const char *name;
5311 const char *suffix;
5312
5313 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5314 continue;
5315 name = SYMBOL_LINKAGE_NAME (sym);
5316 suffix = strstr (name, "___XR");
5317
5318 if (suffix != NULL)
5319 {
5320 int name_len = suffix - name;
5321 int j;
5b4ee69b 5322
aeb5907d 5323 is_new_style_renaming = 1;
54d343a2
TT
5324 for (j = 0; j < syms->size (); j += 1)
5325 if (i != j && (*syms)[j].symbol != NULL
5326 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
aeb5907d 5327 name_len) == 0
54d343a2
TT
5328 && block == (*syms)[j].block)
5329 (*syms)[j].symbol = NULL;
aeb5907d
JB
5330 }
5331 }
5332 if (is_new_style_renaming)
5333 {
5334 int j, k;
5335
54d343a2
TT
5336 for (j = k = 0; j < syms->size (); j += 1)
5337 if ((*syms)[j].symbol != NULL)
aeb5907d 5338 {
54d343a2 5339 (*syms)[k] = (*syms)[j];
aeb5907d
JB
5340 k += 1;
5341 }
5342 return k;
5343 }
4c4b4cd2
PH
5344
5345 /* Extract the function name associated to CURRENT_BLOCK.
5346 Abort if unable to do so. */
76a01679 5347
4c4b4cd2 5348 if (current_block == NULL)
54d343a2 5349 return syms->size ();
76a01679 5350
7f0df278 5351 current_function = block_linkage_function (current_block);
4c4b4cd2 5352 if (current_function == NULL)
54d343a2 5353 return syms->size ();
4c4b4cd2
PH
5354
5355 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5356 if (current_function_name == NULL)
54d343a2 5357 return syms->size ();
4c4b4cd2
PH
5358
5359 /* Check each of the symbols, and remove it from the list if it is
5360 a type corresponding to a renaming that is out of the scope of
5361 the current block. */
5362
5363 i = 0;
54d343a2 5364 while (i < syms->size ())
4c4b4cd2 5365 {
54d343a2 5366 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
aeb5907d 5367 == ADA_OBJECT_RENAMING
54d343a2
TT
5368 && old_renaming_is_invisible ((*syms)[i].symbol,
5369 current_function_name))
5370 syms->erase (syms->begin () + i);
4c4b4cd2
PH
5371 else
5372 i += 1;
5373 }
5374
54d343a2 5375 return syms->size ();
4c4b4cd2
PH
5376}
5377
339c13b6
JB
5378/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5379 whose name and domain match NAME and DOMAIN respectively.
5380 If no match was found, then extend the search to "enclosing"
5381 routines (in other words, if we're inside a nested function,
5382 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5383 If WILD_MATCH_P is nonzero, perform the naming matching in
5384 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5385
5386 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5387
5388static void
b5ec771e
PA
5389ada_add_local_symbols (struct obstack *obstackp,
5390 const lookup_name_info &lookup_name,
5391 const struct block *block, domain_enum domain)
339c13b6
JB
5392{
5393 int block_depth = 0;
5394
5395 while (block != NULL)
5396 {
5397 block_depth += 1;
b5ec771e 5398 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5399
5400 /* If we found a non-function match, assume that's the one. */
5401 if (is_nonfunction (defns_collected (obstackp, 0),
5402 num_defns_collected (obstackp)))
5403 return;
5404
5405 block = BLOCK_SUPERBLOCK (block);
5406 }
5407
5408 /* If no luck so far, try to find NAME as a local symbol in some lexically
5409 enclosing subprogram. */
5410 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5411 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5412}
5413
ccefe4c4 5414/* An object of this type is used as the user_data argument when
40658b94 5415 calling the map_matching_symbols method. */
ccefe4c4 5416
40658b94 5417struct match_data
ccefe4c4 5418{
40658b94 5419 struct objfile *objfile;
ccefe4c4 5420 struct obstack *obstackp;
40658b94
PH
5421 struct symbol *arg_sym;
5422 int found_sym;
ccefe4c4
TT
5423};
5424
22cee43f 5425/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5426 to a list of symbols. DATA0 is a pointer to a struct match_data *
5427 containing the obstack that collects the symbol list, the file that SYM
5428 must come from, a flag indicating whether a non-argument symbol has
5429 been found in the current block, and the last argument symbol
5430 passed in SYM within the current block (if any). When SYM is null,
5431 marking the end of a block, the argument symbol is added if no
5432 other has been found. */
ccefe4c4 5433
40658b94
PH
5434static int
5435aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5436{
40658b94
PH
5437 struct match_data *data = (struct match_data *) data0;
5438
5439 if (sym == NULL)
5440 {
5441 if (!data->found_sym && data->arg_sym != NULL)
5442 add_defn_to_vec (data->obstackp,
5443 fixup_symbol_section (data->arg_sym, data->objfile),
5444 block);
5445 data->found_sym = 0;
5446 data->arg_sym = NULL;
5447 }
5448 else
5449 {
5450 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5451 return 0;
5452 else if (SYMBOL_IS_ARGUMENT (sym))
5453 data->arg_sym = sym;
5454 else
5455 {
5456 data->found_sym = 1;
5457 add_defn_to_vec (data->obstackp,
5458 fixup_symbol_section (sym, data->objfile),
5459 block);
5460 }
5461 }
5462 return 0;
5463}
5464
b5ec771e
PA
5465/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5466 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5467 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5468
5469static int
5470ada_add_block_renamings (struct obstack *obstackp,
5471 const struct block *block,
b5ec771e
PA
5472 const lookup_name_info &lookup_name,
5473 domain_enum domain)
22cee43f
PMR
5474{
5475 struct using_direct *renaming;
5476 int defns_mark = num_defns_collected (obstackp);
5477
b5ec771e
PA
5478 symbol_name_matcher_ftype *name_match
5479 = ada_get_symbol_name_matcher (lookup_name);
5480
22cee43f
PMR
5481 for (renaming = block_using (block);
5482 renaming != NULL;
5483 renaming = renaming->next)
5484 {
5485 const char *r_name;
22cee43f
PMR
5486
5487 /* Avoid infinite recursions: skip this renaming if we are actually
5488 already traversing it.
5489
5490 Currently, symbol lookup in Ada don't use the namespace machinery from
5491 C++/Fortran support: skip namespace imports that use them. */
5492 if (renaming->searched
5493 || (renaming->import_src != NULL
5494 && renaming->import_src[0] != '\0')
5495 || (renaming->import_dest != NULL
5496 && renaming->import_dest[0] != '\0'))
5497 continue;
5498 renaming->searched = 1;
5499
5500 /* TODO: here, we perform another name-based symbol lookup, which can
5501 pull its own multiple overloads. In theory, we should be able to do
5502 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5503 not a simple name. But in order to do this, we would need to enhance
5504 the DWARF reader to associate a symbol to this renaming, instead of a
5505 name. So, for now, we do something simpler: re-use the C++/Fortran
5506 namespace machinery. */
5507 r_name = (renaming->alias != NULL
5508 ? renaming->alias
5509 : renaming->declaration);
b5ec771e
PA
5510 if (name_match (r_name, lookup_name, NULL))
5511 {
5512 lookup_name_info decl_lookup_name (renaming->declaration,
5513 lookup_name.match_type ());
5514 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5515 1, NULL);
5516 }
22cee43f
PMR
5517 renaming->searched = 0;
5518 }
5519 return num_defns_collected (obstackp) != defns_mark;
5520}
5521
db230ce3
JB
5522/* Implements compare_names, but only applying the comparision using
5523 the given CASING. */
5b4ee69b 5524
40658b94 5525static int
db230ce3
JB
5526compare_names_with_case (const char *string1, const char *string2,
5527 enum case_sensitivity casing)
40658b94
PH
5528{
5529 while (*string1 != '\0' && *string2 != '\0')
5530 {
db230ce3
JB
5531 char c1, c2;
5532
40658b94
PH
5533 if (isspace (*string1) || isspace (*string2))
5534 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5535
5536 if (casing == case_sensitive_off)
5537 {
5538 c1 = tolower (*string1);
5539 c2 = tolower (*string2);
5540 }
5541 else
5542 {
5543 c1 = *string1;
5544 c2 = *string2;
5545 }
5546 if (c1 != c2)
40658b94 5547 break;
db230ce3 5548
40658b94
PH
5549 string1 += 1;
5550 string2 += 1;
5551 }
db230ce3 5552
40658b94
PH
5553 switch (*string1)
5554 {
5555 case '(':
5556 return strcmp_iw_ordered (string1, string2);
5557 case '_':
5558 if (*string2 == '\0')
5559 {
052874e8 5560 if (is_name_suffix (string1))
40658b94
PH
5561 return 0;
5562 else
1a1d5513 5563 return 1;
40658b94 5564 }
dbb8534f 5565 /* FALLTHROUGH */
40658b94
PH
5566 default:
5567 if (*string2 == '(')
5568 return strcmp_iw_ordered (string1, string2);
5569 else
db230ce3
JB
5570 {
5571 if (casing == case_sensitive_off)
5572 return tolower (*string1) - tolower (*string2);
5573 else
5574 return *string1 - *string2;
5575 }
40658b94 5576 }
ccefe4c4
TT
5577}
5578
db230ce3
JB
5579/* Compare STRING1 to STRING2, with results as for strcmp.
5580 Compatible with strcmp_iw_ordered in that...
5581
5582 strcmp_iw_ordered (STRING1, STRING2) <= 0
5583
5584 ... implies...
5585
5586 compare_names (STRING1, STRING2) <= 0
5587
5588 (they may differ as to what symbols compare equal). */
5589
5590static int
5591compare_names (const char *string1, const char *string2)
5592{
5593 int result;
5594
5595 /* Similar to what strcmp_iw_ordered does, we need to perform
5596 a case-insensitive comparison first, and only resort to
5597 a second, case-sensitive, comparison if the first one was
5598 not sufficient to differentiate the two strings. */
5599
5600 result = compare_names_with_case (string1, string2, case_sensitive_off);
5601 if (result == 0)
5602 result = compare_names_with_case (string1, string2, case_sensitive_on);
5603
5604 return result;
5605}
5606
b5ec771e
PA
5607/* Convenience function to get at the Ada encoded lookup name for
5608 LOOKUP_NAME, as a C string. */
5609
5610static const char *
5611ada_lookup_name (const lookup_name_info &lookup_name)
5612{
5613 return lookup_name.ada ().lookup_name ().c_str ();
5614}
5615
339c13b6 5616/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5617 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5618 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5619 symbols otherwise. */
339c13b6
JB
5620
5621static void
b5ec771e
PA
5622add_nonlocal_symbols (struct obstack *obstackp,
5623 const lookup_name_info &lookup_name,
5624 domain_enum domain, int global)
339c13b6
JB
5625{
5626 struct objfile *objfile;
22cee43f 5627 struct compunit_symtab *cu;
40658b94 5628 struct match_data data;
339c13b6 5629
6475f2fe 5630 memset (&data, 0, sizeof data);
ccefe4c4 5631 data.obstackp = obstackp;
339c13b6 5632
b5ec771e
PA
5633 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5634
ccefe4c4 5635 ALL_OBJFILES (objfile)
40658b94
PH
5636 {
5637 data.objfile = objfile;
5638
5639 if (is_wild_match)
b5ec771e
PA
5640 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5641 domain, global,
4186eb54 5642 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5643 symbol_name_match_type::WILD,
5644 NULL);
40658b94 5645 else
b5ec771e
PA
5646 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5647 domain, global,
4186eb54 5648 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5649 symbol_name_match_type::FULL,
5650 compare_names);
22cee43f
PMR
5651
5652 ALL_OBJFILE_COMPUNITS (objfile, cu)
5653 {
5654 const struct block *global_block
5655 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5656
b5ec771e
PA
5657 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5658 domain))
22cee43f
PMR
5659 data.found_sym = 1;
5660 }
40658b94
PH
5661 }
5662
5663 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5664 {
b5ec771e
PA
5665 const char *name = ada_lookup_name (lookup_name);
5666 std::string name1 = std::string ("<_ada_") + name + '>';
5667
40658b94
PH
5668 ALL_OBJFILES (objfile)
5669 {
40658b94 5670 data.objfile = objfile;
b5ec771e
PA
5671 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5672 domain, global,
0963b4bd
MS
5673 aux_add_nonlocal_symbols,
5674 &data,
b5ec771e
PA
5675 symbol_name_match_type::FULL,
5676 compare_names);
40658b94
PH
5677 }
5678 }
339c13b6
JB
5679}
5680
b5ec771e
PA
5681/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5682 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5683 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5684
22cee43f
PMR
5685 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5686 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5687 is the one match returned (no other matches in that or
d9680e73 5688 enclosing blocks is returned). If there are any matches in or
22cee43f 5689 surrounding BLOCK, then these alone are returned.
4eeaa230 5690
b5ec771e
PA
5691 Names prefixed with "standard__" are handled specially:
5692 "standard__" is first stripped off (by the lookup_name
5693 constructor), and only static and global symbols are searched.
14f9c5c9 5694
22cee43f
PMR
5695 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5696 to lookup global symbols. */
5697
5698static void
5699ada_add_all_symbols (struct obstack *obstackp,
5700 const struct block *block,
b5ec771e 5701 const lookup_name_info &lookup_name,
22cee43f
PMR
5702 domain_enum domain,
5703 int full_search,
5704 int *made_global_lookup_p)
14f9c5c9
AS
5705{
5706 struct symbol *sym;
14f9c5c9 5707
22cee43f
PMR
5708 if (made_global_lookup_p)
5709 *made_global_lookup_p = 0;
339c13b6
JB
5710
5711 /* Special case: If the user specifies a symbol name inside package
5712 Standard, do a non-wild matching of the symbol name without
5713 the "standard__" prefix. This was primarily introduced in order
5714 to allow the user to specifically access the standard exceptions
5715 using, for instance, Standard.Constraint_Error when Constraint_Error
5716 is ambiguous (due to the user defining its own Constraint_Error
5717 entity inside its program). */
b5ec771e
PA
5718 if (lookup_name.ada ().standard_p ())
5719 block = NULL;
4c4b4cd2 5720
339c13b6 5721 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5722
4eeaa230
DE
5723 if (block != NULL)
5724 {
5725 if (full_search)
b5ec771e 5726 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5727 else
5728 {
5729 /* In the !full_search case we're are being called by
5730 ada_iterate_over_symbols, and we don't want to search
5731 superblocks. */
b5ec771e 5732 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5733 }
22cee43f
PMR
5734 if (num_defns_collected (obstackp) > 0 || !full_search)
5735 return;
4eeaa230 5736 }
d2e4a39e 5737
339c13b6
JB
5738 /* No non-global symbols found. Check our cache to see if we have
5739 already performed this search before. If we have, then return
5740 the same result. */
5741
b5ec771e
PA
5742 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5743 domain, &sym, &block))
4c4b4cd2
PH
5744 {
5745 if (sym != NULL)
b5ec771e 5746 add_defn_to_vec (obstackp, sym, block);
22cee43f 5747 return;
4c4b4cd2 5748 }
14f9c5c9 5749
22cee43f
PMR
5750 if (made_global_lookup_p)
5751 *made_global_lookup_p = 1;
b1eedac9 5752
339c13b6
JB
5753 /* Search symbols from all global blocks. */
5754
b5ec771e 5755 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5756
4c4b4cd2 5757 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5758 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5759
22cee43f 5760 if (num_defns_collected (obstackp) == 0)
b5ec771e 5761 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5762}
5763
b5ec771e
PA
5764/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5765 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5766 matches.
54d343a2
TT
5767 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5768 found and the blocks and symbol tables (if any) in which they were
5769 found.
22cee43f
PMR
5770
5771 When full_search is non-zero, any non-function/non-enumeral
5772 symbol match within the nest of blocks whose innermost member is BLOCK,
5773 is the one match returned (no other matches in that or
5774 enclosing blocks is returned). If there are any matches in or
5775 surrounding BLOCK, then these alone are returned.
5776
5777 Names prefixed with "standard__" are handled specially: "standard__"
5778 is first stripped off, and only static and global symbols are searched. */
5779
5780static int
b5ec771e
PA
5781ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5782 const struct block *block,
22cee43f 5783 domain_enum domain,
54d343a2 5784 std::vector<struct block_symbol> *results,
22cee43f
PMR
5785 int full_search)
5786{
22cee43f
PMR
5787 int syms_from_global_search;
5788 int ndefns;
ec6a20c2 5789 auto_obstack obstack;
22cee43f 5790
ec6a20c2 5791 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5792 domain, full_search, &syms_from_global_search);
14f9c5c9 5793
ec6a20c2
JB
5794 ndefns = num_defns_collected (&obstack);
5795
54d343a2
TT
5796 struct block_symbol *base = defns_collected (&obstack, 1);
5797 for (int i = 0; i < ndefns; ++i)
5798 results->push_back (base[i]);
4c4b4cd2 5799
54d343a2 5800 ndefns = remove_extra_symbols (results);
4c4b4cd2 5801
b1eedac9 5802 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5803 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5804
b1eedac9 5805 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5806 cache_symbol (ada_lookup_name (lookup_name), domain,
5807 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5808
54d343a2 5809 ndefns = remove_irrelevant_renamings (results, block);
ec6a20c2 5810
14f9c5c9
AS
5811 return ndefns;
5812}
5813
b5ec771e 5814/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
54d343a2
TT
5815 in global scopes, returning the number of matches, and filling *RESULTS
5816 with (SYM,BLOCK) tuples.
ec6a20c2 5817
4eeaa230
DE
5818 See ada_lookup_symbol_list_worker for further details. */
5819
5820int
b5ec771e 5821ada_lookup_symbol_list (const char *name, const struct block *block,
54d343a2
TT
5822 domain_enum domain,
5823 std::vector<struct block_symbol> *results)
4eeaa230 5824{
b5ec771e
PA
5825 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5826 lookup_name_info lookup_name (name, name_match_type);
5827
5828 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5829}
5830
5831/* Implementation of the la_iterate_over_symbols method. */
5832
5833static void
14bc53a8 5834ada_iterate_over_symbols
b5ec771e
PA
5835 (const struct block *block, const lookup_name_info &name,
5836 domain_enum domain,
14bc53a8 5837 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5838{
5839 int ndefs, i;
54d343a2 5840 std::vector<struct block_symbol> results;
4eeaa230
DE
5841
5842 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2 5843
4eeaa230
DE
5844 for (i = 0; i < ndefs; ++i)
5845 {
7e41c8db 5846 if (!callback (&results[i]))
4eeaa230
DE
5847 break;
5848 }
5849}
5850
4e5c77fe
JB
5851/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5852 to 1, but choosing the first symbol found if there are multiple
5853 choices.
5854
5e2336be
JB
5855 The result is stored in *INFO, which must be non-NULL.
5856 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5857
5858void
5859ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5860 domain_enum domain,
d12307c1 5861 struct block_symbol *info)
14f9c5c9 5862{
b5ec771e
PA
5863 /* Since we already have an encoded name, wrap it in '<>' to force a
5864 verbatim match. Otherwise, if the name happens to not look like
5865 an encoded name (because it doesn't include a "__"),
5866 ada_lookup_name_info would re-encode/fold it again, and that
5867 would e.g., incorrectly lowercase object renaming names like
5868 "R28b" -> "r28b". */
5869 std::string verbatim = std::string ("<") + name + '>';
5870
5e2336be 5871 gdb_assert (info != NULL);
f98fc17b 5872 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5873}
aeb5907d
JB
5874
5875/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5876 scope and in global scopes, or NULL if none. NAME is folded and
5877 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5878 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5879 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5880
d12307c1 5881struct block_symbol
aeb5907d 5882ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5883 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5884{
5885 if (is_a_field_of_this != NULL)
5886 *is_a_field_of_this = 0;
5887
54d343a2 5888 std::vector<struct block_symbol> candidates;
f98fc17b 5889 int n_candidates;
f98fc17b
PA
5890
5891 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
f98fc17b
PA
5892
5893 if (n_candidates == 0)
54d343a2 5894 return {};
f98fc17b
PA
5895
5896 block_symbol info = candidates[0];
5897 info.symbol = fixup_symbol_section (info.symbol, NULL);
d12307c1 5898 return info;
4c4b4cd2 5899}
14f9c5c9 5900
d12307c1 5901static struct block_symbol
f606139a
DE
5902ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5903 const char *name,
76a01679 5904 const struct block *block,
21b556f4 5905 const domain_enum domain)
4c4b4cd2 5906{
d12307c1 5907 struct block_symbol sym;
04dccad0
JB
5908
5909 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5910 if (sym.symbol != NULL)
04dccad0
JB
5911 return sym;
5912
5913 /* If we haven't found a match at this point, try the primitive
5914 types. In other languages, this search is performed before
5915 searching for global symbols in order to short-circuit that
5916 global-symbol search if it happens that the name corresponds
5917 to a primitive type. But we cannot do the same in Ada, because
5918 it is perfectly legitimate for a program to declare a type which
5919 has the same name as a standard type. If looking up a type in
5920 that situation, we have traditionally ignored the primitive type
5921 in favor of user-defined types. This is why, unlike most other
5922 languages, we search the primitive types this late and only after
5923 having searched the global symbols without success. */
5924
5925 if (domain == VAR_DOMAIN)
5926 {
5927 struct gdbarch *gdbarch;
5928
5929 if (block == NULL)
5930 gdbarch = target_gdbarch ();
5931 else
5932 gdbarch = block_gdbarch (block);
d12307c1
PMR
5933 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5934 if (sym.symbol != NULL)
04dccad0
JB
5935 return sym;
5936 }
5937
d12307c1 5938 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5939}
5940
5941
4c4b4cd2
PH
5942/* True iff STR is a possible encoded suffix of a normal Ada name
5943 that is to be ignored for matching purposes. Suffixes of parallel
5944 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5945 are given by any of the regular expressions:
4c4b4cd2 5946
babe1480
JB
5947 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5948 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5949 TKB [subprogram suffix for task bodies]
babe1480 5950 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5951 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5952
5953 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5954 match is performed. This sequence is used to differentiate homonyms,
5955 is an optional part of a valid name suffix. */
4c4b4cd2 5956
14f9c5c9 5957static int
d2e4a39e 5958is_name_suffix (const char *str)
14f9c5c9
AS
5959{
5960 int k;
4c4b4cd2
PH
5961 const char *matching;
5962 const int len = strlen (str);
5963
babe1480
JB
5964 /* Skip optional leading __[0-9]+. */
5965
4c4b4cd2
PH
5966 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5967 {
babe1480
JB
5968 str += 3;
5969 while (isdigit (str[0]))
5970 str += 1;
4c4b4cd2 5971 }
babe1480
JB
5972
5973 /* [.$][0-9]+ */
4c4b4cd2 5974
babe1480 5975 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5976 {
babe1480 5977 matching = str + 1;
4c4b4cd2
PH
5978 while (isdigit (matching[0]))
5979 matching += 1;
5980 if (matching[0] == '\0')
5981 return 1;
5982 }
5983
5984 /* ___[0-9]+ */
babe1480 5985
4c4b4cd2
PH
5986 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5987 {
5988 matching = str + 3;
5989 while (isdigit (matching[0]))
5990 matching += 1;
5991 if (matching[0] == '\0')
5992 return 1;
5993 }
5994
9ac7f98e
JB
5995 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5996
5997 if (strcmp (str, "TKB") == 0)
5998 return 1;
5999
529cad9c
PH
6000#if 0
6001 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
6002 with a N at the end. Unfortunately, the compiler uses the same
6003 convention for other internal types it creates. So treating
529cad9c 6004 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
6005 some regressions. For instance, consider the case of an enumerated
6006 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
6007 name ends with N.
6008 Having a single character like this as a suffix carrying some
0963b4bd 6009 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
6010 to be something like "_N" instead. In the meantime, do not do
6011 the following check. */
6012 /* Protected Object Subprograms */
6013 if (len == 1 && str [0] == 'N')
6014 return 1;
6015#endif
6016
6017 /* _E[0-9]+[bs]$ */
6018 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6019 {
6020 matching = str + 3;
6021 while (isdigit (matching[0]))
6022 matching += 1;
6023 if ((matching[0] == 'b' || matching[0] == 's')
6024 && matching [1] == '\0')
6025 return 1;
6026 }
6027
4c4b4cd2
PH
6028 /* ??? We should not modify STR directly, as we are doing below. This
6029 is fine in this case, but may become problematic later if we find
6030 that this alternative did not work, and want to try matching
6031 another one from the begining of STR. Since we modified it, we
6032 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6033 if (str[0] == 'X')
6034 {
6035 str += 1;
d2e4a39e 6036 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6037 {
6038 if (str[0] != 'n' && str[0] != 'b')
6039 return 0;
6040 str += 1;
6041 }
14f9c5c9 6042 }
babe1480 6043
14f9c5c9
AS
6044 if (str[0] == '\000')
6045 return 1;
babe1480 6046
d2e4a39e 6047 if (str[0] == '_')
14f9c5c9
AS
6048 {
6049 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6050 return 0;
d2e4a39e 6051 if (str[2] == '_')
4c4b4cd2 6052 {
61ee279c
PH
6053 if (strcmp (str + 3, "JM") == 0)
6054 return 1;
6055 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6056 the LJM suffix in favor of the JM one. But we will
6057 still accept LJM as a valid suffix for a reasonable
6058 amount of time, just to allow ourselves to debug programs
6059 compiled using an older version of GNAT. */
4c4b4cd2
PH
6060 if (strcmp (str + 3, "LJM") == 0)
6061 return 1;
6062 if (str[3] != 'X')
6063 return 0;
1265e4aa
JB
6064 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6065 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6066 return 1;
6067 if (str[4] == 'R' && str[5] != 'T')
6068 return 1;
6069 return 0;
6070 }
6071 if (!isdigit (str[2]))
6072 return 0;
6073 for (k = 3; str[k] != '\0'; k += 1)
6074 if (!isdigit (str[k]) && str[k] != '_')
6075 return 0;
14f9c5c9
AS
6076 return 1;
6077 }
4c4b4cd2 6078 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6079 {
4c4b4cd2
PH
6080 for (k = 2; str[k] != '\0'; k += 1)
6081 if (!isdigit (str[k]) && str[k] != '_')
6082 return 0;
14f9c5c9
AS
6083 return 1;
6084 }
6085 return 0;
6086}
d2e4a39e 6087
aeb5907d
JB
6088/* Return non-zero if the string starting at NAME and ending before
6089 NAME_END contains no capital letters. */
529cad9c
PH
6090
6091static int
6092is_valid_name_for_wild_match (const char *name0)
6093{
6094 const char *decoded_name = ada_decode (name0);
6095 int i;
6096
5823c3ef
JB
6097 /* If the decoded name starts with an angle bracket, it means that
6098 NAME0 does not follow the GNAT encoding format. It should then
6099 not be allowed as a possible wild match. */
6100 if (decoded_name[0] == '<')
6101 return 0;
6102
529cad9c
PH
6103 for (i=0; decoded_name[i] != '\0'; i++)
6104 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6105 return 0;
6106
6107 return 1;
6108}
6109
73589123
PH
6110/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6111 that could start a simple name. Assumes that *NAMEP points into
6112 the string beginning at NAME0. */
4c4b4cd2 6113
14f9c5c9 6114static int
73589123 6115advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6116{
73589123 6117 const char *name = *namep;
5b4ee69b 6118
5823c3ef 6119 while (1)
14f9c5c9 6120 {
aa27d0b3 6121 int t0, t1;
73589123
PH
6122
6123 t0 = *name;
6124 if (t0 == '_')
6125 {
6126 t1 = name[1];
6127 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6128 {
6129 name += 1;
61012eef 6130 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6131 break;
6132 else
6133 name += 1;
6134 }
aa27d0b3
JB
6135 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6136 || name[2] == target0))
73589123
PH
6137 {
6138 name += 2;
6139 break;
6140 }
6141 else
6142 return 0;
6143 }
6144 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6145 name += 1;
6146 else
5823c3ef 6147 return 0;
73589123
PH
6148 }
6149
6150 *namep = name;
6151 return 1;
6152}
6153
b5ec771e
PA
6154/* Return true iff NAME encodes a name of the form prefix.PATN.
6155 Ignores any informational suffixes of NAME (i.e., for which
6156 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6157 simple name. */
73589123 6158
b5ec771e 6159static bool
73589123
PH
6160wild_match (const char *name, const char *patn)
6161{
22e048c9 6162 const char *p;
73589123
PH
6163 const char *name0 = name;
6164
6165 while (1)
6166 {
6167 const char *match = name;
6168
6169 if (*name == *patn)
6170 {
6171 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6172 if (*p != *name)
6173 break;
6174 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6175 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6176
6177 if (name[-1] == '_')
6178 name -= 1;
6179 }
6180 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6181 return false;
96d887e8 6182 }
96d887e8
PH
6183}
6184
b5ec771e
PA
6185/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6186 any trailing suffixes that encode debugging information or leading
6187 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6188 information that is ignored). */
40658b94 6189
b5ec771e 6190static bool
c4d840bd
PH
6191full_match (const char *sym_name, const char *search_name)
6192{
b5ec771e
PA
6193 size_t search_name_len = strlen (search_name);
6194
6195 if (strncmp (sym_name, search_name, search_name_len) == 0
6196 && is_name_suffix (sym_name + search_name_len))
6197 return true;
6198
6199 if (startswith (sym_name, "_ada_")
6200 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6201 && is_name_suffix (sym_name + search_name_len + 5))
6202 return true;
c4d840bd 6203
b5ec771e
PA
6204 return false;
6205}
c4d840bd 6206
b5ec771e
PA
6207/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6208 *defn_symbols, updating the list of symbols in OBSTACKP (if
6209 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6210
6211static void
6212ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6213 const struct block *block,
6214 const lookup_name_info &lookup_name,
6215 domain_enum domain, struct objfile *objfile)
96d887e8 6216{
8157b174 6217 struct block_iterator iter;
96d887e8
PH
6218 /* A matching argument symbol, if any. */
6219 struct symbol *arg_sym;
6220 /* Set true when we find a matching non-argument symbol. */
6221 int found_sym;
6222 struct symbol *sym;
6223
6224 arg_sym = NULL;
6225 found_sym = 0;
b5ec771e
PA
6226 for (sym = block_iter_match_first (block, lookup_name, &iter);
6227 sym != NULL;
6228 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6229 {
b5ec771e
PA
6230 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6231 SYMBOL_DOMAIN (sym), domain))
6232 {
6233 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6234 {
6235 if (SYMBOL_IS_ARGUMENT (sym))
6236 arg_sym = sym;
6237 else
6238 {
6239 found_sym = 1;
6240 add_defn_to_vec (obstackp,
6241 fixup_symbol_section (sym, objfile),
6242 block);
6243 }
6244 }
6245 }
96d887e8
PH
6246 }
6247
22cee43f
PMR
6248 /* Handle renamings. */
6249
b5ec771e 6250 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6251 found_sym = 1;
6252
96d887e8
PH
6253 if (!found_sym && arg_sym != NULL)
6254 {
76a01679
JB
6255 add_defn_to_vec (obstackp,
6256 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6257 block);
96d887e8
PH
6258 }
6259
b5ec771e 6260 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6261 {
6262 arg_sym = NULL;
6263 found_sym = 0;
b5ec771e
PA
6264 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6265 const char *name = ada_lookup_name.c_str ();
6266 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6267
6268 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6269 {
4186eb54
KS
6270 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6271 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6272 {
6273 int cmp;
6274
6275 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6276 if (cmp == 0)
6277 {
61012eef 6278 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6279 if (cmp == 0)
6280 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6281 name_len);
6282 }
6283
6284 if (cmp == 0
6285 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6286 {
2a2d4dc3
AS
6287 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6288 {
6289 if (SYMBOL_IS_ARGUMENT (sym))
6290 arg_sym = sym;
6291 else
6292 {
6293 found_sym = 1;
6294 add_defn_to_vec (obstackp,
6295 fixup_symbol_section (sym, objfile),
6296 block);
6297 }
6298 }
76a01679
JB
6299 }
6300 }
76a01679 6301 }
96d887e8
PH
6302
6303 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6304 They aren't parameters, right? */
6305 if (!found_sym && arg_sym != NULL)
6306 {
6307 add_defn_to_vec (obstackp,
76a01679 6308 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6309 block);
96d887e8
PH
6310 }
6311 }
6312}
6313\f
41d27058
JB
6314
6315 /* Symbol Completion */
6316
b5ec771e 6317/* See symtab.h. */
41d27058 6318
b5ec771e
PA
6319bool
6320ada_lookup_name_info::matches
6321 (const char *sym_name,
6322 symbol_name_match_type match_type,
a207cff2 6323 completion_match_result *comp_match_res) const
41d27058 6324{
b5ec771e
PA
6325 bool match = false;
6326 const char *text = m_encoded_name.c_str ();
6327 size_t text_len = m_encoded_name.size ();
41d27058
JB
6328
6329 /* First, test against the fully qualified name of the symbol. */
6330
6331 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6332 match = true;
41d27058 6333
b5ec771e 6334 if (match && !m_encoded_p)
41d27058
JB
6335 {
6336 /* One needed check before declaring a positive match is to verify
6337 that iff we are doing a verbatim match, the decoded version
6338 of the symbol name starts with '<'. Otherwise, this symbol name
6339 is not a suitable completion. */
6340 const char *sym_name_copy = sym_name;
b5ec771e 6341 bool has_angle_bracket;
41d27058
JB
6342
6343 sym_name = ada_decode (sym_name);
6344 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6345 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6346 sym_name = sym_name_copy;
6347 }
6348
b5ec771e 6349 if (match && !m_verbatim_p)
41d27058
JB
6350 {
6351 /* When doing non-verbatim match, another check that needs to
6352 be done is to verify that the potentially matching symbol name
6353 does not include capital letters, because the ada-mode would
6354 not be able to understand these symbol names without the
6355 angle bracket notation. */
6356 const char *tmp;
6357
6358 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6359 if (*tmp != '\0')
b5ec771e 6360 match = false;
41d27058
JB
6361 }
6362
6363 /* Second: Try wild matching... */
6364
b5ec771e 6365 if (!match && m_wild_match_p)
41d27058
JB
6366 {
6367 /* Since we are doing wild matching, this means that TEXT
6368 may represent an unqualified symbol name. We therefore must
6369 also compare TEXT against the unqualified name of the symbol. */
6370 sym_name = ada_unqualified_name (ada_decode (sym_name));
6371
6372 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6373 match = true;
41d27058
JB
6374 }
6375
b5ec771e 6376 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6377
6378 if (!match)
b5ec771e 6379 return false;
41d27058 6380
a207cff2 6381 if (comp_match_res != NULL)
b5ec771e 6382 {
a207cff2 6383 std::string &match_str = comp_match_res->match.storage ();
41d27058 6384
b5ec771e 6385 if (!m_encoded_p)
a207cff2 6386 match_str = ada_decode (sym_name);
b5ec771e
PA
6387 else
6388 {
6389 if (m_verbatim_p)
6390 match_str = add_angle_brackets (sym_name);
6391 else
6392 match_str = sym_name;
41d27058 6393
b5ec771e 6394 }
a207cff2
PA
6395
6396 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6397 }
6398
b5ec771e 6399 return true;
41d27058
JB
6400}
6401
b5ec771e 6402/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6403 WORD is the entire command on which completion is made. */
41d27058 6404
eb3ff9a5
PA
6405static void
6406ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6407 complete_symbol_mode mode,
b5ec771e
PA
6408 symbol_name_match_type name_match_type,
6409 const char *text, const char *word,
eb3ff9a5 6410 enum type_code code)
41d27058 6411{
41d27058 6412 struct symbol *sym;
43f3e411 6413 struct compunit_symtab *s;
41d27058
JB
6414 struct minimal_symbol *msymbol;
6415 struct objfile *objfile;
3977b71f 6416 const struct block *b, *surrounding_static_block = 0;
8157b174 6417 struct block_iterator iter;
41d27058 6418
2f68a895
TT
6419 gdb_assert (code == TYPE_CODE_UNDEF);
6420
1b026119 6421 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6422
6423 /* First, look at the partial symtab symbols. */
14bc53a8 6424 expand_symtabs_matching (NULL,
b5ec771e
PA
6425 lookup_name,
6426 NULL,
14bc53a8
PA
6427 NULL,
6428 ALL_DOMAIN);
41d27058
JB
6429
6430 /* At this point scan through the misc symbol vectors and add each
6431 symbol you find to the list. Eventually we want to ignore
6432 anything that isn't a text symbol (everything else will be
6433 handled by the psymtab code above). */
6434
6435 ALL_MSYMBOLS (objfile, msymbol)
6436 {
6437 QUIT;
b5ec771e 6438
f9d67a22
PA
6439 if (completion_skip_symbol (mode, msymbol))
6440 continue;
6441
d4c2a405
PA
6442 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6443
6444 /* Ada minimal symbols won't have their language set to Ada. If
6445 we let completion_list_add_name compare using the
6446 default/C-like matcher, then when completing e.g., symbols in a
6447 package named "pck", we'd match internal Ada symbols like
6448 "pckS", which are invalid in an Ada expression, unless you wrap
6449 them in '<' '>' to request a verbatim match.
6450
6451 Unfortunately, some Ada encoded names successfully demangle as
6452 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6453 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6454 with the wrong language set. Paper over that issue here. */
6455 if (symbol_language == language_auto
6456 || symbol_language == language_cplus)
6457 symbol_language = language_ada;
6458
b5ec771e 6459 completion_list_add_name (tracker,
d4c2a405 6460 symbol_language,
b5ec771e 6461 MSYMBOL_LINKAGE_NAME (msymbol),
1b026119 6462 lookup_name, text, word);
41d27058
JB
6463 }
6464
6465 /* Search upwards from currently selected frame (so that we can
6466 complete on local vars. */
6467
6468 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6469 {
6470 if (!BLOCK_SUPERBLOCK (b))
6471 surrounding_static_block = b; /* For elmin of dups */
6472
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
6485 /* Go through the symtabs and check the externs and statics for
43f3e411 6486 symbols which match. */
41d27058 6487
43f3e411 6488 ALL_COMPUNITS (objfile, s)
41d27058
JB
6489 {
6490 QUIT;
43f3e411 6491 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
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 }
6503
43f3e411 6504 ALL_COMPUNITS (objfile, s)
41d27058
JB
6505 {
6506 QUIT;
43f3e411 6507 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6508 /* Don't do this block twice. */
6509 if (b == surrounding_static_block)
6510 continue;
6511 ALL_BLOCK_SYMBOLS (b, iter, sym)
6512 {
f9d67a22
PA
6513 if (completion_skip_symbol (mode, sym))
6514 continue;
6515
b5ec771e
PA
6516 completion_list_add_name (tracker,
6517 SYMBOL_LANGUAGE (sym),
6518 SYMBOL_LINKAGE_NAME (sym),
1b026119 6519 lookup_name, text, word);
41d27058
JB
6520 }
6521 }
41d27058
JB
6522}
6523
963a6417 6524 /* Field Access */
96d887e8 6525
73fb9985
JB
6526/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6527 for tagged types. */
6528
6529static int
6530ada_is_dispatch_table_ptr_type (struct type *type)
6531{
0d5cff50 6532 const char *name;
73fb9985
JB
6533
6534 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6535 return 0;
6536
6537 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6538 if (name == NULL)
6539 return 0;
6540
6541 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6542}
6543
ac4a2da4
JG
6544/* Return non-zero if TYPE is an interface tag. */
6545
6546static int
6547ada_is_interface_tag (struct type *type)
6548{
6549 const char *name = TYPE_NAME (type);
6550
6551 if (name == NULL)
6552 return 0;
6553
6554 return (strcmp (name, "ada__tags__interface_tag") == 0);
6555}
6556
963a6417
PH
6557/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6558 to be invisible to users. */
96d887e8 6559
963a6417
PH
6560int
6561ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6562{
963a6417
PH
6563 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6564 return 1;
ffde82bf 6565
73fb9985
JB
6566 /* Check the name of that field. */
6567 {
6568 const char *name = TYPE_FIELD_NAME (type, field_num);
6569
6570 /* Anonymous field names should not be printed.
6571 brobecker/2007-02-20: I don't think this can actually happen
6572 but we don't want to print the value of annonymous fields anyway. */
6573 if (name == NULL)
6574 return 1;
6575
ffde82bf
JB
6576 /* Normally, fields whose name start with an underscore ("_")
6577 are fields that have been internally generated by the compiler,
6578 and thus should not be printed. The "_parent" field is special,
6579 however: This is a field internally generated by the compiler
6580 for tagged types, and it contains the components inherited from
6581 the parent type. This field should not be printed as is, but
6582 should not be ignored either. */
61012eef 6583 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6584 return 1;
6585 }
6586
ac4a2da4
JG
6587 /* If this is the dispatch table of a tagged type or an interface tag,
6588 then ignore. */
73fb9985 6589 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6590 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6591 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6592 return 1;
6593
6594 /* Not a special field, so it should not be ignored. */
6595 return 0;
963a6417 6596}
96d887e8 6597
963a6417 6598/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6599 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6600
963a6417
PH
6601int
6602ada_is_tagged_type (struct type *type, int refok)
6603{
988f6b3d 6604 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6605}
96d887e8 6606
963a6417 6607/* True iff TYPE represents the type of X'Tag */
96d887e8 6608
963a6417
PH
6609int
6610ada_is_tag_type (struct type *type)
6611{
460efde1
JB
6612 type = ada_check_typedef (type);
6613
963a6417
PH
6614 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6615 return 0;
6616 else
96d887e8 6617 {
963a6417 6618 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6619
963a6417
PH
6620 return (name != NULL
6621 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6622 }
96d887e8
PH
6623}
6624
963a6417 6625/* The type of the tag on VAL. */
76a01679 6626
963a6417
PH
6627struct type *
6628ada_tag_type (struct value *val)
96d887e8 6629{
988f6b3d 6630 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6631}
96d887e8 6632
b50d69b5
JG
6633/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6634 retired at Ada 05). */
6635
6636static int
6637is_ada95_tag (struct value *tag)
6638{
6639 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6640}
6641
963a6417 6642/* The value of the tag on VAL. */
96d887e8 6643
963a6417
PH
6644struct value *
6645ada_value_tag (struct value *val)
6646{
03ee6b2e 6647 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6648}
6649
963a6417
PH
6650/* The value of the tag on the object of type TYPE whose contents are
6651 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6652 ADDRESS. */
96d887e8 6653
963a6417 6654static struct value *
10a2c479 6655value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6656 const gdb_byte *valaddr,
963a6417 6657 CORE_ADDR address)
96d887e8 6658{
b5385fc0 6659 int tag_byte_offset;
963a6417 6660 struct type *tag_type;
5b4ee69b 6661
963a6417 6662 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6663 NULL, NULL, NULL))
96d887e8 6664 {
fc1a4b47 6665 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6666 ? NULL
6667 : valaddr + tag_byte_offset);
963a6417 6668 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6669
963a6417 6670 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6671 }
963a6417
PH
6672 return NULL;
6673}
96d887e8 6674
963a6417
PH
6675static struct type *
6676type_from_tag (struct value *tag)
6677{
6678 const char *type_name = ada_tag_name (tag);
5b4ee69b 6679
963a6417
PH
6680 if (type_name != NULL)
6681 return ada_find_any_type (ada_encode (type_name));
6682 return NULL;
6683}
96d887e8 6684
b50d69b5
JG
6685/* Given a value OBJ of a tagged type, return a value of this
6686 type at the base address of the object. The base address, as
6687 defined in Ada.Tags, it is the address of the primary tag of
6688 the object, and therefore where the field values of its full
6689 view can be fetched. */
6690
6691struct value *
6692ada_tag_value_at_base_address (struct value *obj)
6693{
b50d69b5
JG
6694 struct value *val;
6695 LONGEST offset_to_top = 0;
6696 struct type *ptr_type, *obj_type;
6697 struct value *tag;
6698 CORE_ADDR base_address;
6699
6700 obj_type = value_type (obj);
6701
6702 /* It is the responsability of the caller to deref pointers. */
6703
6704 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6705 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6706 return obj;
6707
6708 tag = ada_value_tag (obj);
6709 if (!tag)
6710 return obj;
6711
6712 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6713
6714 if (is_ada95_tag (tag))
6715 return obj;
6716
08f49010
XR
6717 ptr_type = language_lookup_primitive_type
6718 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6719 ptr_type = lookup_pointer_type (ptr_type);
6720 val = value_cast (ptr_type, tag);
6721 if (!val)
6722 return obj;
6723
6724 /* It is perfectly possible that an exception be raised while
6725 trying to determine the base address, just like for the tag;
6726 see ada_tag_name for more details. We do not print the error
6727 message for the same reason. */
6728
492d29ea 6729 TRY
b50d69b5
JG
6730 {
6731 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6732 }
6733
492d29ea
PA
6734 CATCH (e, RETURN_MASK_ERROR)
6735 {
6736 return obj;
6737 }
6738 END_CATCH
b50d69b5
JG
6739
6740 /* If offset is null, nothing to do. */
6741
6742 if (offset_to_top == 0)
6743 return obj;
6744
6745 /* -1 is a special case in Ada.Tags; however, what should be done
6746 is not quite clear from the documentation. So do nothing for
6747 now. */
6748
6749 if (offset_to_top == -1)
6750 return obj;
6751
08f49010
XR
6752 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6753 from the base address. This was however incompatible with
6754 C++ dispatch table: C++ uses a *negative* value to *add*
6755 to the base address. Ada's convention has therefore been
6756 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6757 use the same convention. Here, we support both cases by
6758 checking the sign of OFFSET_TO_TOP. */
6759
6760 if (offset_to_top > 0)
6761 offset_to_top = -offset_to_top;
6762
6763 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6764 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6765
6766 /* Make sure that we have a proper tag at the new address.
6767 Otherwise, offset_to_top is bogus (which can happen when
6768 the object is not initialized yet). */
6769
6770 if (!tag)
6771 return obj;
6772
6773 obj_type = type_from_tag (tag);
6774
6775 if (!obj_type)
6776 return obj;
6777
6778 return value_from_contents_and_address (obj_type, NULL, base_address);
6779}
6780
1b611343
JB
6781/* Return the "ada__tags__type_specific_data" type. */
6782
6783static struct type *
6784ada_get_tsd_type (struct inferior *inf)
963a6417 6785{
1b611343 6786 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6787
1b611343
JB
6788 if (data->tsd_type == 0)
6789 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6790 return data->tsd_type;
6791}
529cad9c 6792
1b611343
JB
6793/* Return the TSD (type-specific data) associated to the given TAG.
6794 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6795
1b611343 6796 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6797
1b611343
JB
6798static struct value *
6799ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6800{
4c4b4cd2 6801 struct value *val;
1b611343 6802 struct type *type;
5b4ee69b 6803
1b611343
JB
6804 /* First option: The TSD is simply stored as a field of our TAG.
6805 Only older versions of GNAT would use this format, but we have
6806 to test it first, because there are no visible markers for
6807 the current approach except the absence of that field. */
529cad9c 6808
1b611343
JB
6809 val = ada_value_struct_elt (tag, "tsd", 1);
6810 if (val)
6811 return val;
e802dbe0 6812
1b611343
JB
6813 /* Try the second representation for the dispatch table (in which
6814 there is no explicit 'tsd' field in the referent of the tag pointer,
6815 and instead the tsd pointer is stored just before the dispatch
6816 table. */
e802dbe0 6817
1b611343
JB
6818 type = ada_get_tsd_type (current_inferior());
6819 if (type == NULL)
6820 return NULL;
6821 type = lookup_pointer_type (lookup_pointer_type (type));
6822 val = value_cast (type, tag);
6823 if (val == NULL)
6824 return NULL;
6825 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6826}
6827
1b611343
JB
6828/* Given the TSD of a tag (type-specific data), return a string
6829 containing the name of the associated type.
6830
6831 The returned value is good until the next call. May return NULL
6832 if we are unable to determine the tag name. */
6833
6834static char *
6835ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6836{
529cad9c
PH
6837 static char name[1024];
6838 char *p;
1b611343 6839 struct value *val;
529cad9c 6840
1b611343 6841 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6842 if (val == NULL)
1b611343 6843 return NULL;
4c4b4cd2
PH
6844 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6845 for (p = name; *p != '\0'; p += 1)
6846 if (isalpha (*p))
6847 *p = tolower (*p);
1b611343 6848 return name;
4c4b4cd2
PH
6849}
6850
6851/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6852 a C string.
6853
6854 Return NULL if the TAG is not an Ada tag, or if we were unable to
6855 determine the name of that tag. The result is good until the next
6856 call. */
4c4b4cd2
PH
6857
6858const char *
6859ada_tag_name (struct value *tag)
6860{
1b611343 6861 char *name = NULL;
5b4ee69b 6862
df407dfe 6863 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6864 return NULL;
1b611343
JB
6865
6866 /* It is perfectly possible that an exception be raised while trying
6867 to determine the TAG's name, even under normal circumstances:
6868 The associated variable may be uninitialized or corrupted, for
6869 instance. We do not let any exception propagate past this point.
6870 instead we return NULL.
6871
6872 We also do not print the error message either (which often is very
6873 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6874 the caller print a more meaningful message if necessary. */
492d29ea 6875 TRY
1b611343
JB
6876 {
6877 struct value *tsd = ada_get_tsd_from_tag (tag);
6878
6879 if (tsd != NULL)
6880 name = ada_tag_name_from_tsd (tsd);
6881 }
492d29ea
PA
6882 CATCH (e, RETURN_MASK_ERROR)
6883 {
6884 }
6885 END_CATCH
1b611343
JB
6886
6887 return name;
4c4b4cd2
PH
6888}
6889
6890/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6891
d2e4a39e 6892struct type *
ebf56fd3 6893ada_parent_type (struct type *type)
14f9c5c9
AS
6894{
6895 int i;
6896
61ee279c 6897 type = ada_check_typedef (type);
14f9c5c9
AS
6898
6899 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6900 return NULL;
6901
6902 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6903 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6904 {
6905 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6906
6907 /* If the _parent field is a pointer, then dereference it. */
6908 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6909 parent_type = TYPE_TARGET_TYPE (parent_type);
6910 /* If there is a parallel XVS type, get the actual base type. */
6911 parent_type = ada_get_base_type (parent_type);
6912
6913 return ada_check_typedef (parent_type);
6914 }
14f9c5c9
AS
6915
6916 return NULL;
6917}
6918
4c4b4cd2
PH
6919/* True iff field number FIELD_NUM of structure type TYPE contains the
6920 parent-type (inherited) fields of a derived type. Assumes TYPE is
6921 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6922
6923int
ebf56fd3 6924ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6925{
61ee279c 6926 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6927
4c4b4cd2 6928 return (name != NULL
61012eef
GB
6929 && (startswith (name, "PARENT")
6930 || startswith (name, "_parent")));
14f9c5c9
AS
6931}
6932
4c4b4cd2 6933/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6934 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6935 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6936 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6937 structures. */
14f9c5c9
AS
6938
6939int
ebf56fd3 6940ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6941{
d2e4a39e 6942 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6943
dddc0e16
JB
6944 if (name != NULL && strcmp (name, "RETVAL") == 0)
6945 {
6946 /* This happens in functions with "out" or "in out" parameters
6947 which are passed by copy. For such functions, GNAT describes
6948 the function's return type as being a struct where the return
6949 value is in a field called RETVAL, and where the other "out"
6950 or "in out" parameters are fields of that struct. This is not
6951 a wrapper. */
6952 return 0;
6953 }
6954
d2e4a39e 6955 return (name != NULL
61012eef 6956 && (startswith (name, "PARENT")
4c4b4cd2 6957 || strcmp (name, "REP") == 0
61012eef 6958 || startswith (name, "_parent")
4c4b4cd2 6959 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6960}
6961
4c4b4cd2
PH
6962/* True iff field number FIELD_NUM of structure or union type TYPE
6963 is a variant wrapper. Assumes TYPE is a structure type with at least
6964 FIELD_NUM+1 fields. */
14f9c5c9
AS
6965
6966int
ebf56fd3 6967ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6968{
d2e4a39e 6969 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6970
14f9c5c9 6971 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6972 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6973 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6974 == TYPE_CODE_UNION)));
14f9c5c9
AS
6975}
6976
6977/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6978 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6979 returns the type of the controlling discriminant for the variant.
6980 May return NULL if the type could not be found. */
14f9c5c9 6981
d2e4a39e 6982struct type *
ebf56fd3 6983ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6984{
a121b7c1 6985 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6986
988f6b3d 6987 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
6988}
6989
4c4b4cd2 6990/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6991 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6992 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6993
6994int
ebf56fd3 6995ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6996{
d2e4a39e 6997 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6998
14f9c5c9
AS
6999 return (name != NULL && name[0] == 'O');
7000}
7001
7002/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
7003 returns the name of the discriminant controlling the variant.
7004 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 7005
a121b7c1 7006const char *
ebf56fd3 7007ada_variant_discrim_name (struct type *type0)
14f9c5c9 7008{
d2e4a39e 7009 static char *result = NULL;
14f9c5c9 7010 static size_t result_len = 0;
d2e4a39e
AS
7011 struct type *type;
7012 const char *name;
7013 const char *discrim_end;
7014 const char *discrim_start;
14f9c5c9
AS
7015
7016 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7017 type = TYPE_TARGET_TYPE (type0);
7018 else
7019 type = type0;
7020
7021 name = ada_type_name (type);
7022
7023 if (name == NULL || name[0] == '\000')
7024 return "";
7025
7026 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7027 discrim_end -= 1)
7028 {
61012eef 7029 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7030 break;
14f9c5c9
AS
7031 }
7032 if (discrim_end == name)
7033 return "";
7034
d2e4a39e 7035 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7036 discrim_start -= 1)
7037 {
d2e4a39e 7038 if (discrim_start == name + 1)
4c4b4cd2 7039 return "";
76a01679 7040 if ((discrim_start > name + 3
61012eef 7041 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7042 || discrim_start[-1] == '.')
7043 break;
14f9c5c9
AS
7044 }
7045
7046 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7047 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7048 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7049 return result;
7050}
7051
4c4b4cd2
PH
7052/* Scan STR for a subtype-encoded number, beginning at position K.
7053 Put the position of the character just past the number scanned in
7054 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7055 Return 1 if there was a valid number at the given position, and 0
7056 otherwise. A "subtype-encoded" number consists of the absolute value
7057 in decimal, followed by the letter 'm' to indicate a negative number.
7058 Assumes 0m does not occur. */
14f9c5c9
AS
7059
7060int
d2e4a39e 7061ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7062{
7063 ULONGEST RU;
7064
d2e4a39e 7065 if (!isdigit (str[k]))
14f9c5c9
AS
7066 return 0;
7067
4c4b4cd2 7068 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7069 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7070 LONGEST. */
14f9c5c9
AS
7071 RU = 0;
7072 while (isdigit (str[k]))
7073 {
d2e4a39e 7074 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7075 k += 1;
7076 }
7077
d2e4a39e 7078 if (str[k] == 'm')
14f9c5c9
AS
7079 {
7080 if (R != NULL)
4c4b4cd2 7081 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7082 k += 1;
7083 }
7084 else if (R != NULL)
7085 *R = (LONGEST) RU;
7086
4c4b4cd2 7087 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7088 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7089 number representable as a LONGEST (although either would probably work
7090 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7091 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7092
7093 if (new_k != NULL)
7094 *new_k = k;
7095 return 1;
7096}
7097
4c4b4cd2
PH
7098/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7099 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7100 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7101
d2e4a39e 7102int
ebf56fd3 7103ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7104{
d2e4a39e 7105 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7106 int p;
7107
7108 p = 0;
7109 while (1)
7110 {
d2e4a39e 7111 switch (name[p])
4c4b4cd2
PH
7112 {
7113 case '\0':
7114 return 0;
7115 case 'S':
7116 {
7117 LONGEST W;
5b4ee69b 7118
4c4b4cd2
PH
7119 if (!ada_scan_number (name, p + 1, &W, &p))
7120 return 0;
7121 if (val == W)
7122 return 1;
7123 break;
7124 }
7125 case 'R':
7126 {
7127 LONGEST L, U;
5b4ee69b 7128
4c4b4cd2
PH
7129 if (!ada_scan_number (name, p + 1, &L, &p)
7130 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7131 return 0;
7132 if (val >= L && val <= U)
7133 return 1;
7134 break;
7135 }
7136 case 'O':
7137 return 1;
7138 default:
7139 return 0;
7140 }
7141 }
7142}
7143
0963b4bd 7144/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7145
7146/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7147 ARG_TYPE, extract and return the value of one of its (non-static)
7148 fields. FIELDNO says which field. Differs from value_primitive_field
7149 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7150
4c4b4cd2 7151static struct value *
d2e4a39e 7152ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7153 struct type *arg_type)
14f9c5c9 7154{
14f9c5c9
AS
7155 struct type *type;
7156
61ee279c 7157 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7158 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7159
4c4b4cd2 7160 /* Handle packed fields. */
14f9c5c9
AS
7161
7162 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7163 {
7164 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7165 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7166
0fd88904 7167 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7168 offset + bit_pos / 8,
7169 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7170 }
7171 else
7172 return value_primitive_field (arg1, offset, fieldno, arg_type);
7173}
7174
52ce6436
PH
7175/* Find field with name NAME in object of type TYPE. If found,
7176 set the following for each argument that is non-null:
7177 - *FIELD_TYPE_P to the field's type;
7178 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7179 an object of that type;
7180 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7181 - *BIT_SIZE_P to its size in bits if the field is packed, and
7182 0 otherwise;
7183 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7184 fields up to but not including the desired field, or by the total
7185 number of fields if not found. A NULL value of NAME never
7186 matches; the function just counts visible fields in this case.
7187
828d5846
XR
7188 Notice that we need to handle when a tagged record hierarchy
7189 has some components with the same name, like in this scenario:
7190
7191 type Top_T is tagged record
7192 N : Integer := 1;
7193 U : Integer := 974;
7194 A : Integer := 48;
7195 end record;
7196
7197 type Middle_T is new Top.Top_T with record
7198 N : Character := 'a';
7199 C : Integer := 3;
7200 end record;
7201
7202 type Bottom_T is new Middle.Middle_T with record
7203 N : Float := 4.0;
7204 C : Character := '5';
7205 X : Integer := 6;
7206 A : Character := 'J';
7207 end record;
7208
7209 Let's say we now have a variable declared and initialized as follow:
7210
7211 TC : Top_A := new Bottom_T;
7212
7213 And then we use this variable to call this function
7214
7215 procedure Assign (Obj: in out Top_T; TV : Integer);
7216
7217 as follow:
7218
7219 Assign (Top_T (B), 12);
7220
7221 Now, we're in the debugger, and we're inside that procedure
7222 then and we want to print the value of obj.c:
7223
7224 Usually, the tagged record or one of the parent type owns the
7225 component to print and there's no issue but in this particular
7226 case, what does it mean to ask for Obj.C? Since the actual
7227 type for object is type Bottom_T, it could mean two things: type
7228 component C from the Middle_T view, but also component C from
7229 Bottom_T. So in that "undefined" case, when the component is
7230 not found in the non-resolved type (which includes all the
7231 components of the parent type), then resolve it and see if we
7232 get better luck once expanded.
7233
7234 In the case of homonyms in the derived tagged type, we don't
7235 guaranty anything, and pick the one that's easiest for us
7236 to program.
7237
0963b4bd 7238 Returns 1 if found, 0 otherwise. */
52ce6436 7239
4c4b4cd2 7240static int
0d5cff50 7241find_struct_field (const char *name, struct type *type, int offset,
76a01679 7242 struct type **field_type_p,
52ce6436
PH
7243 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7244 int *index_p)
4c4b4cd2
PH
7245{
7246 int i;
828d5846 7247 int parent_offset = -1;
4c4b4cd2 7248
61ee279c 7249 type = ada_check_typedef (type);
76a01679 7250
52ce6436
PH
7251 if (field_type_p != NULL)
7252 *field_type_p = NULL;
7253 if (byte_offset_p != NULL)
d5d6fca5 7254 *byte_offset_p = 0;
52ce6436
PH
7255 if (bit_offset_p != NULL)
7256 *bit_offset_p = 0;
7257 if (bit_size_p != NULL)
7258 *bit_size_p = 0;
7259
7260 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7261 {
7262 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7263 int fld_offset = offset + bit_pos / 8;
0d5cff50 7264 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7265
4c4b4cd2
PH
7266 if (t_field_name == NULL)
7267 continue;
7268
828d5846
XR
7269 else if (ada_is_parent_field (type, i))
7270 {
7271 /* This is a field pointing us to the parent type of a tagged
7272 type. As hinted in this function's documentation, we give
7273 preference to fields in the current record first, so what
7274 we do here is just record the index of this field before
7275 we skip it. If it turns out we couldn't find our field
7276 in the current record, then we'll get back to it and search
7277 inside it whether the field might exist in the parent. */
7278
7279 parent_offset = i;
7280 continue;
7281 }
7282
52ce6436 7283 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7284 {
7285 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7286
52ce6436
PH
7287 if (field_type_p != NULL)
7288 *field_type_p = TYPE_FIELD_TYPE (type, i);
7289 if (byte_offset_p != NULL)
7290 *byte_offset_p = fld_offset;
7291 if (bit_offset_p != NULL)
7292 *bit_offset_p = bit_pos % 8;
7293 if (bit_size_p != NULL)
7294 *bit_size_p = bit_size;
76a01679
JB
7295 return 1;
7296 }
4c4b4cd2
PH
7297 else if (ada_is_wrapper_field (type, i))
7298 {
52ce6436
PH
7299 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7300 field_type_p, byte_offset_p, bit_offset_p,
7301 bit_size_p, index_p))
76a01679
JB
7302 return 1;
7303 }
4c4b4cd2
PH
7304 else if (ada_is_variant_part (type, i))
7305 {
52ce6436
PH
7306 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7307 fixed type?? */
4c4b4cd2 7308 int j;
52ce6436
PH
7309 struct type *field_type
7310 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7311
52ce6436 7312 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7313 {
76a01679
JB
7314 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7315 fld_offset
7316 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7317 field_type_p, byte_offset_p,
52ce6436 7318 bit_offset_p, bit_size_p, index_p))
76a01679 7319 return 1;
4c4b4cd2
PH
7320 }
7321 }
52ce6436
PH
7322 else if (index_p != NULL)
7323 *index_p += 1;
4c4b4cd2 7324 }
828d5846
XR
7325
7326 /* Field not found so far. If this is a tagged type which
7327 has a parent, try finding that field in the parent now. */
7328
7329 if (parent_offset != -1)
7330 {
7331 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7332 int fld_offset = offset + bit_pos / 8;
7333
7334 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7335 fld_offset, field_type_p, byte_offset_p,
7336 bit_offset_p, bit_size_p, index_p))
7337 return 1;
7338 }
7339
4c4b4cd2
PH
7340 return 0;
7341}
7342
0963b4bd 7343/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7344
52ce6436
PH
7345static int
7346num_visible_fields (struct type *type)
7347{
7348 int n;
5b4ee69b 7349
52ce6436
PH
7350 n = 0;
7351 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7352 return n;
7353}
14f9c5c9 7354
4c4b4cd2 7355/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7356 and search in it assuming it has (class) type TYPE.
7357 If found, return value, else return NULL.
7358
828d5846
XR
7359 Searches recursively through wrapper fields (e.g., '_parent').
7360
7361 In the case of homonyms in the tagged types, please refer to the
7362 long explanation in find_struct_field's function documentation. */
14f9c5c9 7363
4c4b4cd2 7364static struct value *
108d56a4 7365ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7366 struct type *type)
14f9c5c9
AS
7367{
7368 int i;
828d5846 7369 int parent_offset = -1;
14f9c5c9 7370
5b4ee69b 7371 type = ada_check_typedef (type);
52ce6436 7372 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7373 {
0d5cff50 7374 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7375
7376 if (t_field_name == NULL)
4c4b4cd2 7377 continue;
14f9c5c9 7378
828d5846
XR
7379 else if (ada_is_parent_field (type, i))
7380 {
7381 /* This is a field pointing us to the parent type of a tagged
7382 type. As hinted in this function's documentation, we give
7383 preference to fields in the current record first, so what
7384 we do here is just record the index of this field before
7385 we skip it. If it turns out we couldn't find our field
7386 in the current record, then we'll get back to it and search
7387 inside it whether the field might exist in the parent. */
7388
7389 parent_offset = i;
7390 continue;
7391 }
7392
14f9c5c9 7393 else if (field_name_match (t_field_name, name))
4c4b4cd2 7394 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7395
7396 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7397 {
0963b4bd 7398 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7399 ada_search_struct_field (name, arg,
7400 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7401 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7402
4c4b4cd2
PH
7403 if (v != NULL)
7404 return v;
7405 }
14f9c5c9
AS
7406
7407 else if (ada_is_variant_part (type, i))
4c4b4cd2 7408 {
0963b4bd 7409 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7410 int j;
5b4ee69b
MS
7411 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7412 i));
4c4b4cd2
PH
7413 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7414
52ce6436 7415 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7416 {
0963b4bd
MS
7417 struct value *v = ada_search_struct_field /* Force line
7418 break. */
06d5cf63
JB
7419 (name, arg,
7420 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7421 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7422
4c4b4cd2
PH
7423 if (v != NULL)
7424 return v;
7425 }
7426 }
14f9c5c9 7427 }
828d5846
XR
7428
7429 /* Field not found so far. If this is a tagged type which
7430 has a parent, try finding that field in the parent now. */
7431
7432 if (parent_offset != -1)
7433 {
7434 struct value *v = ada_search_struct_field (
7435 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7436 TYPE_FIELD_TYPE (type, parent_offset));
7437
7438 if (v != NULL)
7439 return v;
7440 }
7441
14f9c5c9
AS
7442 return NULL;
7443}
d2e4a39e 7444
52ce6436
PH
7445static struct value *ada_index_struct_field_1 (int *, struct value *,
7446 int, struct type *);
7447
7448
7449/* Return field #INDEX in ARG, where the index is that returned by
7450 * find_struct_field through its INDEX_P argument. Adjust the address
7451 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7452 * If found, return value, else return NULL. */
52ce6436
PH
7453
7454static struct value *
7455ada_index_struct_field (int index, struct value *arg, int offset,
7456 struct type *type)
7457{
7458 return ada_index_struct_field_1 (&index, arg, offset, type);
7459}
7460
7461
7462/* Auxiliary function for ada_index_struct_field. Like
7463 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7464 * *INDEX_P. */
52ce6436
PH
7465
7466static struct value *
7467ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7468 struct type *type)
7469{
7470 int i;
7471 type = ada_check_typedef (type);
7472
7473 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7474 {
7475 if (TYPE_FIELD_NAME (type, i) == NULL)
7476 continue;
7477 else if (ada_is_wrapper_field (type, i))
7478 {
0963b4bd 7479 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7480 ada_index_struct_field_1 (index_p, arg,
7481 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7482 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7483
52ce6436
PH
7484 if (v != NULL)
7485 return v;
7486 }
7487
7488 else if (ada_is_variant_part (type, i))
7489 {
7490 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7491 find_struct_field. */
52ce6436
PH
7492 error (_("Cannot assign this kind of variant record"));
7493 }
7494 else if (*index_p == 0)
7495 return ada_value_primitive_field (arg, offset, i, type);
7496 else
7497 *index_p -= 1;
7498 }
7499 return NULL;
7500}
7501
4c4b4cd2
PH
7502/* Given ARG, a value of type (pointer or reference to a)*
7503 structure/union, extract the component named NAME from the ultimate
7504 target structure/union and return it as a value with its
f5938064 7505 appropriate type.
14f9c5c9 7506
4c4b4cd2
PH
7507 The routine searches for NAME among all members of the structure itself
7508 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7509 (e.g., '_parent').
7510
03ee6b2e
PH
7511 If NO_ERR, then simply return NULL in case of error, rather than
7512 calling error. */
14f9c5c9 7513
d2e4a39e 7514struct value *
a121b7c1 7515ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7516{
4c4b4cd2 7517 struct type *t, *t1;
d2e4a39e 7518 struct value *v;
14f9c5c9 7519
4c4b4cd2 7520 v = NULL;
df407dfe 7521 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7522 if (TYPE_CODE (t) == TYPE_CODE_REF)
7523 {
7524 t1 = TYPE_TARGET_TYPE (t);
7525 if (t1 == NULL)
03ee6b2e 7526 goto BadValue;
61ee279c 7527 t1 = ada_check_typedef (t1);
4c4b4cd2 7528 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7529 {
994b9211 7530 arg = coerce_ref (arg);
76a01679
JB
7531 t = t1;
7532 }
4c4b4cd2 7533 }
14f9c5c9 7534
4c4b4cd2
PH
7535 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7536 {
7537 t1 = TYPE_TARGET_TYPE (t);
7538 if (t1 == NULL)
03ee6b2e 7539 goto BadValue;
61ee279c 7540 t1 = ada_check_typedef (t1);
4c4b4cd2 7541 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7542 {
7543 arg = value_ind (arg);
7544 t = t1;
7545 }
4c4b4cd2 7546 else
76a01679 7547 break;
4c4b4cd2 7548 }
14f9c5c9 7549
4c4b4cd2 7550 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7551 goto BadValue;
14f9c5c9 7552
4c4b4cd2
PH
7553 if (t1 == t)
7554 v = ada_search_struct_field (name, arg, 0, t);
7555 else
7556 {
7557 int bit_offset, bit_size, byte_offset;
7558 struct type *field_type;
7559 CORE_ADDR address;
7560
76a01679 7561 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7562 address = value_address (ada_value_ind (arg));
4c4b4cd2 7563 else
b50d69b5 7564 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7565
828d5846
XR
7566 /* Check to see if this is a tagged type. We also need to handle
7567 the case where the type is a reference to a tagged type, but
7568 we have to be careful to exclude pointers to tagged types.
7569 The latter should be shown as usual (as a pointer), whereas
7570 a reference should mostly be transparent to the user. */
7571
7572 if (ada_is_tagged_type (t1, 0)
7573 || (TYPE_CODE (t1) == TYPE_CODE_REF
7574 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7575 {
7576 /* We first try to find the searched field in the current type.
7577 If not found then let's look in the fixed type. */
7578
7579 if (!find_struct_field (name, t1, 0,
7580 &field_type, &byte_offset, &bit_offset,
7581 &bit_size, NULL))
7582 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7583 address, NULL, 1);
7584 }
7585 else
7586 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7587 address, NULL, 1);
7588
76a01679
JB
7589 if (find_struct_field (name, t1, 0,
7590 &field_type, &byte_offset, &bit_offset,
52ce6436 7591 &bit_size, NULL))
76a01679
JB
7592 {
7593 if (bit_size != 0)
7594 {
714e53ab
PH
7595 if (TYPE_CODE (t) == TYPE_CODE_REF)
7596 arg = ada_coerce_ref (arg);
7597 else
7598 arg = ada_value_ind (arg);
76a01679
JB
7599 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7600 bit_offset, bit_size,
7601 field_type);
7602 }
7603 else
f5938064 7604 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7605 }
7606 }
7607
03ee6b2e
PH
7608 if (v != NULL || no_err)
7609 return v;
7610 else
323e0a4a 7611 error (_("There is no member named %s."), name);
14f9c5c9 7612
03ee6b2e
PH
7613 BadValue:
7614 if (no_err)
7615 return NULL;
7616 else
0963b4bd
MS
7617 error (_("Attempt to extract a component of "
7618 "a value that is not a record."));
14f9c5c9
AS
7619}
7620
3b4de39c 7621/* Return a string representation of type TYPE. */
99bbb428 7622
3b4de39c 7623static std::string
99bbb428
PA
7624type_as_string (struct type *type)
7625{
d7e74731 7626 string_file tmp_stream;
99bbb428 7627
d7e74731 7628 type_print (type, "", &tmp_stream, -1);
99bbb428 7629
d7e74731 7630 return std::move (tmp_stream.string ());
99bbb428
PA
7631}
7632
14f9c5c9 7633/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7634 If DISPP is non-null, add its byte displacement from the beginning of a
7635 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7636 work for packed fields).
7637
7638 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7639 followed by "___".
14f9c5c9 7640
0963b4bd 7641 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7642 be a (pointer or reference)+ to a struct or union, and the
7643 ultimate target type will be searched.
14f9c5c9
AS
7644
7645 Looks recursively into variant clauses and parent types.
7646
828d5846
XR
7647 In the case of homonyms in the tagged types, please refer to the
7648 long explanation in find_struct_field's function documentation.
7649
4c4b4cd2
PH
7650 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7651 TYPE is not a type of the right kind. */
14f9c5c9 7652
4c4b4cd2 7653static struct type *
a121b7c1 7654ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7655 int noerr)
14f9c5c9
AS
7656{
7657 int i;
828d5846 7658 int parent_offset = -1;
14f9c5c9
AS
7659
7660 if (name == NULL)
7661 goto BadName;
7662
76a01679 7663 if (refok && type != NULL)
4c4b4cd2
PH
7664 while (1)
7665 {
61ee279c 7666 type = ada_check_typedef (type);
76a01679
JB
7667 if (TYPE_CODE (type) != TYPE_CODE_PTR
7668 && TYPE_CODE (type) != TYPE_CODE_REF)
7669 break;
7670 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7671 }
14f9c5c9 7672
76a01679 7673 if (type == NULL
1265e4aa
JB
7674 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7675 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7676 {
4c4b4cd2 7677 if (noerr)
76a01679 7678 return NULL;
99bbb428 7679
3b4de39c
PA
7680 error (_("Type %s is not a structure or union type"),
7681 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7682 }
7683
7684 type = to_static_fixed_type (type);
7685
7686 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7687 {
0d5cff50 7688 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7689 struct type *t;
d2e4a39e 7690
14f9c5c9 7691 if (t_field_name == NULL)
4c4b4cd2 7692 continue;
14f9c5c9 7693
828d5846
XR
7694 else if (ada_is_parent_field (type, i))
7695 {
7696 /* This is a field pointing us to the parent type of a tagged
7697 type. As hinted in this function's documentation, we give
7698 preference to fields in the current record first, so what
7699 we do here is just record the index of this field before
7700 we skip it. If it turns out we couldn't find our field
7701 in the current record, then we'll get back to it and search
7702 inside it whether the field might exist in the parent. */
7703
7704 parent_offset = i;
7705 continue;
7706 }
7707
14f9c5c9 7708 else if (field_name_match (t_field_name, name))
988f6b3d 7709 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7710
7711 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7712 {
4c4b4cd2 7713 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7714 0, 1);
4c4b4cd2 7715 if (t != NULL)
988f6b3d 7716 return t;
4c4b4cd2 7717 }
14f9c5c9
AS
7718
7719 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7720 {
7721 int j;
5b4ee69b
MS
7722 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7723 i));
4c4b4cd2
PH
7724
7725 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7726 {
b1f33ddd
JB
7727 /* FIXME pnh 2008/01/26: We check for a field that is
7728 NOT wrapped in a struct, since the compiler sometimes
7729 generates these for unchecked variant types. Revisit
0963b4bd 7730 if the compiler changes this practice. */
0d5cff50 7731 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7732
b1f33ddd
JB
7733 if (v_field_name != NULL
7734 && field_name_match (v_field_name, name))
460efde1 7735 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7736 else
0963b4bd
MS
7737 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7738 j),
988f6b3d 7739 name, 0, 1);
b1f33ddd 7740
4c4b4cd2 7741 if (t != NULL)
988f6b3d 7742 return t;
4c4b4cd2
PH
7743 }
7744 }
14f9c5c9
AS
7745
7746 }
7747
828d5846
XR
7748 /* Field not found so far. If this is a tagged type which
7749 has a parent, try finding that field in the parent now. */
7750
7751 if (parent_offset != -1)
7752 {
7753 struct type *t;
7754
7755 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7756 name, 0, 1);
7757 if (t != NULL)
7758 return t;
7759 }
7760
14f9c5c9 7761BadName:
d2e4a39e 7762 if (!noerr)
14f9c5c9 7763 {
2b2798cc 7764 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7765
7766 error (_("Type %s has no component named %s"),
3b4de39c 7767 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7768 }
7769
7770 return NULL;
7771}
7772
b1f33ddd
JB
7773/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7774 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7775 represents an unchecked union (that is, the variant part of a
0963b4bd 7776 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7777
7778static int
7779is_unchecked_variant (struct type *var_type, struct type *outer_type)
7780{
a121b7c1 7781 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7782
988f6b3d 7783 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7784}
7785
7786
14f9c5c9
AS
7787/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7788 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7789 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7790 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7791
d2e4a39e 7792int
ebf56fd3 7793ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7794 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7795{
7796 int others_clause;
7797 int i;
a121b7c1 7798 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7799 struct value *outer;
7800 struct value *discrim;
14f9c5c9
AS
7801 LONGEST discrim_val;
7802
012370f6
TT
7803 /* Using plain value_from_contents_and_address here causes problems
7804 because we will end up trying to resolve a type that is currently
7805 being constructed. */
7806 outer = value_from_contents_and_address_unresolved (outer_type,
7807 outer_valaddr, 0);
0c281816
JB
7808 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7809 if (discrim == NULL)
14f9c5c9 7810 return -1;
0c281816 7811 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7812
7813 others_clause = -1;
7814 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7815 {
7816 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7817 others_clause = i;
14f9c5c9 7818 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7819 return i;
14f9c5c9
AS
7820 }
7821
7822 return others_clause;
7823}
d2e4a39e 7824\f
14f9c5c9
AS
7825
7826
4c4b4cd2 7827 /* Dynamic-Sized Records */
14f9c5c9
AS
7828
7829/* Strategy: The type ostensibly attached to a value with dynamic size
7830 (i.e., a size that is not statically recorded in the debugging
7831 data) does not accurately reflect the size or layout of the value.
7832 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7833 conventional types that are constructed on the fly. */
14f9c5c9
AS
7834
7835/* There is a subtle and tricky problem here. In general, we cannot
7836 determine the size of dynamic records without its data. However,
7837 the 'struct value' data structure, which GDB uses to represent
7838 quantities in the inferior process (the target), requires the size
7839 of the type at the time of its allocation in order to reserve space
7840 for GDB's internal copy of the data. That's why the
7841 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7842 rather than struct value*s.
14f9c5c9
AS
7843
7844 However, GDB's internal history variables ($1, $2, etc.) are
7845 struct value*s containing internal copies of the data that are not, in
7846 general, the same as the data at their corresponding addresses in
7847 the target. Fortunately, the types we give to these values are all
7848 conventional, fixed-size types (as per the strategy described
7849 above), so that we don't usually have to perform the
7850 'to_fixed_xxx_type' conversions to look at their values.
7851 Unfortunately, there is one exception: if one of the internal
7852 history variables is an array whose elements are unconstrained
7853 records, then we will need to create distinct fixed types for each
7854 element selected. */
7855
7856/* The upshot of all of this is that many routines take a (type, host
7857 address, target address) triple as arguments to represent a value.
7858 The host address, if non-null, is supposed to contain an internal
7859 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7860 target at the target address. */
14f9c5c9
AS
7861
7862/* Assuming that VAL0 represents a pointer value, the result of
7863 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7864 dynamic-sized types. */
14f9c5c9 7865
d2e4a39e
AS
7866struct value *
7867ada_value_ind (struct value *val0)
14f9c5c9 7868{
c48db5ca 7869 struct value *val = value_ind (val0);
5b4ee69b 7870
b50d69b5
JG
7871 if (ada_is_tagged_type (value_type (val), 0))
7872 val = ada_tag_value_at_base_address (val);
7873
4c4b4cd2 7874 return ada_to_fixed_value (val);
14f9c5c9
AS
7875}
7876
7877/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7878 qualifiers on VAL0. */
7879
d2e4a39e
AS
7880static struct value *
7881ada_coerce_ref (struct value *val0)
7882{
df407dfe 7883 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7884 {
7885 struct value *val = val0;
5b4ee69b 7886
994b9211 7887 val = coerce_ref (val);
b50d69b5
JG
7888
7889 if (ada_is_tagged_type (value_type (val), 0))
7890 val = ada_tag_value_at_base_address (val);
7891
4c4b4cd2 7892 return ada_to_fixed_value (val);
d2e4a39e
AS
7893 }
7894 else
14f9c5c9
AS
7895 return val0;
7896}
7897
7898/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7899 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7900
7901static unsigned int
ebf56fd3 7902align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7903{
7904 return (off + alignment - 1) & ~(alignment - 1);
7905}
7906
4c4b4cd2 7907/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7908
7909static unsigned int
ebf56fd3 7910field_alignment (struct type *type, int f)
14f9c5c9 7911{
d2e4a39e 7912 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7913 int len;
14f9c5c9
AS
7914 int align_offset;
7915
64a1bf19
JB
7916 /* The field name should never be null, unless the debugging information
7917 is somehow malformed. In this case, we assume the field does not
7918 require any alignment. */
7919 if (name == NULL)
7920 return 1;
7921
7922 len = strlen (name);
7923
4c4b4cd2
PH
7924 if (!isdigit (name[len - 1]))
7925 return 1;
14f9c5c9 7926
d2e4a39e 7927 if (isdigit (name[len - 2]))
14f9c5c9
AS
7928 align_offset = len - 2;
7929 else
7930 align_offset = len - 1;
7931
61012eef 7932 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7933 return TARGET_CHAR_BIT;
7934
4c4b4cd2
PH
7935 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7936}
7937
852dff6c 7938/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7939
852dff6c
JB
7940static struct symbol *
7941ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7942{
7943 struct symbol *sym;
7944
7945 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7946 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7947 return sym;
7948
4186eb54
KS
7949 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7950 return sym;
14f9c5c9
AS
7951}
7952
dddfab26
UW
7953/* Find a type named NAME. Ignores ambiguity. This routine will look
7954 solely for types defined by debug info, it will not search the GDB
7955 primitive types. */
4c4b4cd2 7956
852dff6c 7957static struct type *
ebf56fd3 7958ada_find_any_type (const char *name)
14f9c5c9 7959{
852dff6c 7960 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7961
14f9c5c9 7962 if (sym != NULL)
dddfab26 7963 return SYMBOL_TYPE (sym);
14f9c5c9 7964
dddfab26 7965 return NULL;
14f9c5c9
AS
7966}
7967
739593e0
JB
7968/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7969 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7970 symbol, in which case it is returned. Otherwise, this looks for
7971 symbols whose name is that of NAME_SYM suffixed with "___XR".
7972 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7973
7974struct symbol *
270140bd 7975ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7976{
739593e0 7977 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7978 struct symbol *sym;
7979
739593e0
JB
7980 if (strstr (name, "___XR") != NULL)
7981 return name_sym;
7982
aeb5907d
JB
7983 sym = find_old_style_renaming_symbol (name, block);
7984
7985 if (sym != NULL)
7986 return sym;
7987
0963b4bd 7988 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7989 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7990 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7991 return sym;
7992 else
7993 return NULL;
7994}
7995
7996static struct symbol *
270140bd 7997find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7998{
7f0df278 7999 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
8000 char *rename;
8001
8002 if (function_sym != NULL)
8003 {
8004 /* If the symbol is defined inside a function, NAME is not fully
8005 qualified. This means we need to prepend the function name
8006 as well as adding the ``___XR'' suffix to build the name of
8007 the associated renaming symbol. */
0d5cff50 8008 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
8009 /* Function names sometimes contain suffixes used
8010 for instance to qualify nested subprograms. When building
8011 the XR type name, we need to make sure that this suffix is
8012 not included. So do not include any suffix in the function
8013 name length below. */
69fadcdf 8014 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
8015 const int rename_len = function_name_len + 2 /* "__" */
8016 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 8017
529cad9c 8018 /* Strip the suffix if necessary. */
69fadcdf
JB
8019 ada_remove_trailing_digits (function_name, &function_name_len);
8020 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8021 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 8022
4c4b4cd2
PH
8023 /* Library-level functions are a special case, as GNAT adds
8024 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 8025 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
8026 have this prefix, so we need to skip this prefix if present. */
8027 if (function_name_len > 5 /* "_ada_" */
8028 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
8029 {
8030 function_name += 5;
8031 function_name_len -= 5;
8032 }
4c4b4cd2
PH
8033
8034 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
8035 strncpy (rename, function_name, function_name_len);
8036 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8037 "__%s___XR", name);
4c4b4cd2
PH
8038 }
8039 else
8040 {
8041 const int rename_len = strlen (name) + 6;
5b4ee69b 8042
4c4b4cd2 8043 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 8044 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
8045 }
8046
852dff6c 8047 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
8048}
8049
14f9c5c9 8050/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 8051 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 8052 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
8053 otherwise return 0. */
8054
14f9c5c9 8055int
d2e4a39e 8056ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
8057{
8058 if (type1 == NULL)
8059 return 1;
8060 else if (type0 == NULL)
8061 return 0;
8062 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8063 return 1;
8064 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8065 return 0;
4c4b4cd2
PH
8066 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8067 return 1;
ad82864c 8068 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8069 return 1;
4c4b4cd2
PH
8070 else if (ada_is_array_descriptor_type (type0)
8071 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8072 return 1;
aeb5907d
JB
8073 else
8074 {
a737d952
TT
8075 const char *type0_name = TYPE_NAME (type0);
8076 const char *type1_name = TYPE_NAME (type1);
aeb5907d
JB
8077
8078 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8079 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8080 return 1;
8081 }
14f9c5c9
AS
8082 return 0;
8083}
8084
e86ca25f
TT
8085/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
8086 null. */
4c4b4cd2 8087
0d5cff50 8088const char *
d2e4a39e 8089ada_type_name (struct type *type)
14f9c5c9 8090{
d2e4a39e 8091 if (type == NULL)
14f9c5c9 8092 return NULL;
e86ca25f 8093 return TYPE_NAME (type);
14f9c5c9
AS
8094}
8095
b4ba55a1
JB
8096/* Search the list of "descriptive" types associated to TYPE for a type
8097 whose name is NAME. */
8098
8099static struct type *
8100find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8101{
931e5bc3 8102 struct type *result, *tmp;
b4ba55a1 8103
c6044dd1
JB
8104 if (ada_ignore_descriptive_types_p)
8105 return NULL;
8106
b4ba55a1
JB
8107 /* If there no descriptive-type info, then there is no parallel type
8108 to be found. */
8109 if (!HAVE_GNAT_AUX_INFO (type))
8110 return NULL;
8111
8112 result = TYPE_DESCRIPTIVE_TYPE (type);
8113 while (result != NULL)
8114 {
0d5cff50 8115 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8116
8117 if (result_name == NULL)
8118 {
8119 warning (_("unexpected null name on descriptive type"));
8120 return NULL;
8121 }
8122
8123 /* If the names match, stop. */
8124 if (strcmp (result_name, name) == 0)
8125 break;
8126
8127 /* Otherwise, look at the next item on the list, if any. */
8128 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8129 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8130 else
8131 tmp = NULL;
8132
8133 /* If not found either, try after having resolved the typedef. */
8134 if (tmp != NULL)
8135 result = tmp;
b4ba55a1 8136 else
931e5bc3 8137 {
f168693b 8138 result = check_typedef (result);
931e5bc3
JG
8139 if (HAVE_GNAT_AUX_INFO (result))
8140 result = TYPE_DESCRIPTIVE_TYPE (result);
8141 else
8142 result = NULL;
8143 }
b4ba55a1
JB
8144 }
8145
8146 /* If we didn't find a match, see whether this is a packed array. With
8147 older compilers, the descriptive type information is either absent or
8148 irrelevant when it comes to packed arrays so the above lookup fails.
8149 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8150 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8151 return ada_find_any_type (name);
8152
8153 return result;
8154}
8155
8156/* Find a parallel type to TYPE with the specified NAME, using the
8157 descriptive type taken from the debugging information, if available,
8158 and otherwise using the (slower) name-based method. */
8159
8160static struct type *
8161ada_find_parallel_type_with_name (struct type *type, const char *name)
8162{
8163 struct type *result = NULL;
8164
8165 if (HAVE_GNAT_AUX_INFO (type))
8166 result = find_parallel_type_by_descriptive_type (type, name);
8167 else
8168 result = ada_find_any_type (name);
8169
8170 return result;
8171}
8172
8173/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8174 SUFFIX to the name of TYPE. */
14f9c5c9 8175
d2e4a39e 8176struct type *
ebf56fd3 8177ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8178{
0d5cff50 8179 char *name;
fe978cb0 8180 const char *type_name = ada_type_name (type);
14f9c5c9 8181 int len;
d2e4a39e 8182
fe978cb0 8183 if (type_name == NULL)
14f9c5c9
AS
8184 return NULL;
8185
fe978cb0 8186 len = strlen (type_name);
14f9c5c9 8187
b4ba55a1 8188 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8189
fe978cb0 8190 strcpy (name, type_name);
14f9c5c9
AS
8191 strcpy (name + len, suffix);
8192
b4ba55a1 8193 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8194}
8195
14f9c5c9 8196/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8197 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8198
d2e4a39e
AS
8199static struct type *
8200dynamic_template_type (struct type *type)
14f9c5c9 8201{
61ee279c 8202 type = ada_check_typedef (type);
14f9c5c9
AS
8203
8204 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8205 || ada_type_name (type) == NULL)
14f9c5c9 8206 return NULL;
d2e4a39e 8207 else
14f9c5c9
AS
8208 {
8209 int len = strlen (ada_type_name (type));
5b4ee69b 8210
4c4b4cd2
PH
8211 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8212 return type;
14f9c5c9 8213 else
4c4b4cd2 8214 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8215 }
8216}
8217
8218/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8219 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8220
d2e4a39e
AS
8221static int
8222is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8223{
8224 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8225
d2e4a39e 8226 return name != NULL
14f9c5c9
AS
8227 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8228 && strstr (name, "___XVL") != NULL;
8229}
8230
4c4b4cd2
PH
8231/* The index of the variant field of TYPE, or -1 if TYPE does not
8232 represent a variant record type. */
14f9c5c9 8233
d2e4a39e 8234static int
4c4b4cd2 8235variant_field_index (struct type *type)
14f9c5c9
AS
8236{
8237 int f;
8238
4c4b4cd2
PH
8239 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8240 return -1;
8241
8242 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8243 {
8244 if (ada_is_variant_part (type, f))
8245 return f;
8246 }
8247 return -1;
14f9c5c9
AS
8248}
8249
4c4b4cd2
PH
8250/* A record type with no fields. */
8251
d2e4a39e 8252static struct type *
fe978cb0 8253empty_record (struct type *templ)
14f9c5c9 8254{
fe978cb0 8255 struct type *type = alloc_type_copy (templ);
5b4ee69b 8256
14f9c5c9
AS
8257 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8258 TYPE_NFIELDS (type) = 0;
8259 TYPE_FIELDS (type) = NULL;
b1f33ddd 8260 INIT_CPLUS_SPECIFIC (type);
14f9c5c9 8261 TYPE_NAME (type) = "<empty>";
14f9c5c9
AS
8262 TYPE_LENGTH (type) = 0;
8263 return type;
8264}
8265
8266/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8267 the value of type TYPE at VALADDR or ADDRESS (see comments at
8268 the beginning of this section) VAL according to GNAT conventions.
8269 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8270 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8271 an outer-level type (i.e., as opposed to a branch of a variant.) A
8272 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8273 of the variant.
14f9c5c9 8274
4c4b4cd2
PH
8275 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8276 length are not statically known are discarded. As a consequence,
8277 VALADDR, ADDRESS and DVAL0 are ignored.
8278
8279 NOTE: Limitations: For now, we assume that dynamic fields and
8280 variants occupy whole numbers of bytes. However, they need not be
8281 byte-aligned. */
8282
8283struct type *
10a2c479 8284ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8285 const gdb_byte *valaddr,
4c4b4cd2
PH
8286 CORE_ADDR address, struct value *dval0,
8287 int keep_dynamic_fields)
14f9c5c9 8288{
d2e4a39e
AS
8289 struct value *mark = value_mark ();
8290 struct value *dval;
8291 struct type *rtype;
14f9c5c9 8292 int nfields, bit_len;
4c4b4cd2 8293 int variant_field;
14f9c5c9 8294 long off;
d94e4f4f 8295 int fld_bit_len;
14f9c5c9
AS
8296 int f;
8297
4c4b4cd2
PH
8298 /* Compute the number of fields in this record type that are going
8299 to be processed: unless keep_dynamic_fields, this includes only
8300 fields whose position and length are static will be processed. */
8301 if (keep_dynamic_fields)
8302 nfields = TYPE_NFIELDS (type);
8303 else
8304 {
8305 nfields = 0;
76a01679 8306 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8307 && !ada_is_variant_part (type, nfields)
8308 && !is_dynamic_field (type, nfields))
8309 nfields++;
8310 }
8311
e9bb382b 8312 rtype = alloc_type_copy (type);
14f9c5c9
AS
8313 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8314 INIT_CPLUS_SPECIFIC (rtype);
8315 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8316 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8317 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8318 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8319 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8320 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8321
d2e4a39e
AS
8322 off = 0;
8323 bit_len = 0;
4c4b4cd2
PH
8324 variant_field = -1;
8325
14f9c5c9
AS
8326 for (f = 0; f < nfields; f += 1)
8327 {
6c038f32
PH
8328 off = align_value (off, field_alignment (type, f))
8329 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8330 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8331 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8332
d2e4a39e 8333 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8334 {
8335 variant_field = f;
d94e4f4f 8336 fld_bit_len = 0;
4c4b4cd2 8337 }
14f9c5c9 8338 else if (is_dynamic_field (type, f))
4c4b4cd2 8339 {
284614f0
JB
8340 const gdb_byte *field_valaddr = valaddr;
8341 CORE_ADDR field_address = address;
8342 struct type *field_type =
8343 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8344
4c4b4cd2 8345 if (dval0 == NULL)
b5304971
JG
8346 {
8347 /* rtype's length is computed based on the run-time
8348 value of discriminants. If the discriminants are not
8349 initialized, the type size may be completely bogus and
0963b4bd 8350 GDB may fail to allocate a value for it. So check the
b5304971 8351 size first before creating the value. */
c1b5a1a6 8352 ada_ensure_varsize_limit (rtype);
012370f6
TT
8353 /* Using plain value_from_contents_and_address here
8354 causes problems because we will end up trying to
8355 resolve a type that is currently being
8356 constructed. */
8357 dval = value_from_contents_and_address_unresolved (rtype,
8358 valaddr,
8359 address);
9f1f738a 8360 rtype = value_type (dval);
b5304971 8361 }
4c4b4cd2
PH
8362 else
8363 dval = dval0;
8364
284614f0
JB
8365 /* If the type referenced by this field is an aligner type, we need
8366 to unwrap that aligner type, because its size might not be set.
8367 Keeping the aligner type would cause us to compute the wrong
8368 size for this field, impacting the offset of the all the fields
8369 that follow this one. */
8370 if (ada_is_aligner_type (field_type))
8371 {
8372 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8373
8374 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8375 field_address = cond_offset_target (field_address, field_offset);
8376 field_type = ada_aligned_type (field_type);
8377 }
8378
8379 field_valaddr = cond_offset_host (field_valaddr,
8380 off / TARGET_CHAR_BIT);
8381 field_address = cond_offset_target (field_address,
8382 off / TARGET_CHAR_BIT);
8383
8384 /* Get the fixed type of the field. Note that, in this case,
8385 we do not want to get the real type out of the tag: if
8386 the current field is the parent part of a tagged record,
8387 we will get the tag of the object. Clearly wrong: the real
8388 type of the parent is not the real type of the child. We
8389 would end up in an infinite loop. */
8390 field_type = ada_get_base_type (field_type);
8391 field_type = ada_to_fixed_type (field_type, field_valaddr,
8392 field_address, dval, 0);
27f2a97b
JB
8393 /* If the field size is already larger than the maximum
8394 object size, then the record itself will necessarily
8395 be larger than the maximum object size. We need to make
8396 this check now, because the size might be so ridiculously
8397 large (due to an uninitialized variable in the inferior)
8398 that it would cause an overflow when adding it to the
8399 record size. */
c1b5a1a6 8400 ada_ensure_varsize_limit (field_type);
284614f0
JB
8401
8402 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8403 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8404 /* The multiplication can potentially overflow. But because
8405 the field length has been size-checked just above, and
8406 assuming that the maximum size is a reasonable value,
8407 an overflow should not happen in practice. So rather than
8408 adding overflow recovery code to this already complex code,
8409 we just assume that it's not going to happen. */
d94e4f4f 8410 fld_bit_len =
4c4b4cd2
PH
8411 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8412 }
14f9c5c9 8413 else
4c4b4cd2 8414 {
5ded5331
JB
8415 /* Note: If this field's type is a typedef, it is important
8416 to preserve the typedef layer.
8417
8418 Otherwise, we might be transforming a typedef to a fat
8419 pointer (encoding a pointer to an unconstrained array),
8420 into a basic fat pointer (encoding an unconstrained
8421 array). As both types are implemented using the same
8422 structure, the typedef is the only clue which allows us
8423 to distinguish between the two options. Stripping it
8424 would prevent us from printing this field appropriately. */
8425 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8426 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8427 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8428 fld_bit_len =
4c4b4cd2
PH
8429 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8430 else
5ded5331
JB
8431 {
8432 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8433
8434 /* We need to be careful of typedefs when computing
8435 the length of our field. If this is a typedef,
8436 get the length of the target type, not the length
8437 of the typedef. */
8438 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8439 field_type = ada_typedef_target_type (field_type);
8440
8441 fld_bit_len =
8442 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8443 }
4c4b4cd2 8444 }
14f9c5c9 8445 if (off + fld_bit_len > bit_len)
4c4b4cd2 8446 bit_len = off + fld_bit_len;
d94e4f4f 8447 off += fld_bit_len;
4c4b4cd2
PH
8448 TYPE_LENGTH (rtype) =
8449 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8450 }
4c4b4cd2
PH
8451
8452 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8453 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8454 the record. This can happen in the presence of representation
8455 clauses. */
8456 if (variant_field >= 0)
8457 {
8458 struct type *branch_type;
8459
8460 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8461
8462 if (dval0 == NULL)
9f1f738a 8463 {
012370f6
TT
8464 /* Using plain value_from_contents_and_address here causes
8465 problems because we will end up trying to resolve a type
8466 that is currently being constructed. */
8467 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8468 address);
9f1f738a
SA
8469 rtype = value_type (dval);
8470 }
4c4b4cd2
PH
8471 else
8472 dval = dval0;
8473
8474 branch_type =
8475 to_fixed_variant_branch_type
8476 (TYPE_FIELD_TYPE (type, variant_field),
8477 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8478 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8479 if (branch_type == NULL)
8480 {
8481 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8482 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8483 TYPE_NFIELDS (rtype) -= 1;
8484 }
8485 else
8486 {
8487 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8488 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8489 fld_bit_len =
8490 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8491 TARGET_CHAR_BIT;
8492 if (off + fld_bit_len > bit_len)
8493 bit_len = off + fld_bit_len;
8494 TYPE_LENGTH (rtype) =
8495 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8496 }
8497 }
8498
714e53ab
PH
8499 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8500 should contain the alignment of that record, which should be a strictly
8501 positive value. If null or negative, then something is wrong, most
8502 probably in the debug info. In that case, we don't round up the size
0963b4bd 8503 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8504 the current RTYPE length might be good enough for our purposes. */
8505 if (TYPE_LENGTH (type) <= 0)
8506 {
323e0a4a
AC
8507 if (TYPE_NAME (rtype))
8508 warning (_("Invalid type size for `%s' detected: %d."),
8509 TYPE_NAME (rtype), TYPE_LENGTH (type));
8510 else
8511 warning (_("Invalid type size for <unnamed> detected: %d."),
8512 TYPE_LENGTH (type));
714e53ab
PH
8513 }
8514 else
8515 {
8516 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8517 TYPE_LENGTH (type));
8518 }
14f9c5c9
AS
8519
8520 value_free_to_mark (mark);
d2e4a39e 8521 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8522 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8523 return rtype;
8524}
8525
4c4b4cd2
PH
8526/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8527 of 1. */
14f9c5c9 8528
d2e4a39e 8529static struct type *
fc1a4b47 8530template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8531 CORE_ADDR address, struct value *dval0)
8532{
8533 return ada_template_to_fixed_record_type_1 (type, valaddr,
8534 address, dval0, 1);
8535}
8536
8537/* An ordinary record type in which ___XVL-convention fields and
8538 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8539 static approximations, containing all possible fields. Uses
8540 no runtime values. Useless for use in values, but that's OK,
8541 since the results are used only for type determinations. Works on both
8542 structs and unions. Representation note: to save space, we memorize
8543 the result of this function in the TYPE_TARGET_TYPE of the
8544 template type. */
8545
8546static struct type *
8547template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8548{
8549 struct type *type;
8550 int nfields;
8551 int f;
8552
9e195661
PMR
8553 /* No need no do anything if the input type is already fixed. */
8554 if (TYPE_FIXED_INSTANCE (type0))
8555 return type0;
8556
8557 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8558 if (TYPE_TARGET_TYPE (type0) != NULL)
8559 return TYPE_TARGET_TYPE (type0);
8560
9e195661 8561 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8562 type = type0;
9e195661
PMR
8563 nfields = TYPE_NFIELDS (type0);
8564
8565 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8566 recompute all over next time. */
8567 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8568
8569 for (f = 0; f < nfields; f += 1)
8570 {
460efde1 8571 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8572 struct type *new_type;
14f9c5c9 8573
4c4b4cd2 8574 if (is_dynamic_field (type0, f))
460efde1
JB
8575 {
8576 field_type = ada_check_typedef (field_type);
8577 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8578 }
14f9c5c9 8579 else
f192137b 8580 new_type = static_unwrap_type (field_type);
9e195661
PMR
8581
8582 if (new_type != field_type)
8583 {
8584 /* Clone TYPE0 only the first time we get a new field type. */
8585 if (type == type0)
8586 {
8587 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8588 TYPE_CODE (type) = TYPE_CODE (type0);
8589 INIT_CPLUS_SPECIFIC (type);
8590 TYPE_NFIELDS (type) = nfields;
8591 TYPE_FIELDS (type) = (struct field *)
8592 TYPE_ALLOC (type, nfields * sizeof (struct field));
8593 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8594 sizeof (struct field) * nfields);
8595 TYPE_NAME (type) = ada_type_name (type0);
9e195661
PMR
8596 TYPE_FIXED_INSTANCE (type) = 1;
8597 TYPE_LENGTH (type) = 0;
8598 }
8599 TYPE_FIELD_TYPE (type, f) = new_type;
8600 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8601 }
14f9c5c9 8602 }
9e195661 8603
14f9c5c9
AS
8604 return type;
8605}
8606
4c4b4cd2 8607/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8608 whose address in memory is ADDRESS, returns a revision of TYPE,
8609 which should be a non-dynamic-sized record, in which the variant
8610 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8611 for discriminant values in DVAL0, which can be NULL if the record
8612 contains the necessary discriminant values. */
8613
d2e4a39e 8614static struct type *
fc1a4b47 8615to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8616 CORE_ADDR address, struct value *dval0)
14f9c5c9 8617{
d2e4a39e 8618 struct value *mark = value_mark ();
4c4b4cd2 8619 struct value *dval;
d2e4a39e 8620 struct type *rtype;
14f9c5c9
AS
8621 struct type *branch_type;
8622 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8623 int variant_field = variant_field_index (type);
14f9c5c9 8624
4c4b4cd2 8625 if (variant_field == -1)
14f9c5c9
AS
8626 return type;
8627
4c4b4cd2 8628 if (dval0 == NULL)
9f1f738a
SA
8629 {
8630 dval = value_from_contents_and_address (type, valaddr, address);
8631 type = value_type (dval);
8632 }
4c4b4cd2
PH
8633 else
8634 dval = dval0;
8635
e9bb382b 8636 rtype = alloc_type_copy (type);
14f9c5c9 8637 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8638 INIT_CPLUS_SPECIFIC (rtype);
8639 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8640 TYPE_FIELDS (rtype) =
8641 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8642 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8643 sizeof (struct field) * nfields);
14f9c5c9 8644 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8645 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8646 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8647
4c4b4cd2
PH
8648 branch_type = to_fixed_variant_branch_type
8649 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8650 cond_offset_host (valaddr,
4c4b4cd2
PH
8651 TYPE_FIELD_BITPOS (type, variant_field)
8652 / TARGET_CHAR_BIT),
d2e4a39e 8653 cond_offset_target (address,
4c4b4cd2
PH
8654 TYPE_FIELD_BITPOS (type, variant_field)
8655 / TARGET_CHAR_BIT), dval);
d2e4a39e 8656 if (branch_type == NULL)
14f9c5c9 8657 {
4c4b4cd2 8658 int f;
5b4ee69b 8659
4c4b4cd2
PH
8660 for (f = variant_field + 1; f < nfields; f += 1)
8661 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8662 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8663 }
8664 else
8665 {
4c4b4cd2
PH
8666 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8667 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8668 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8669 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8670 }
4c4b4cd2 8671 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8672
4c4b4cd2 8673 value_free_to_mark (mark);
14f9c5c9
AS
8674 return rtype;
8675}
8676
8677/* An ordinary record type (with fixed-length fields) that describes
8678 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8679 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8680 should be in DVAL, a record value; it may be NULL if the object
8681 at ADDR itself contains any necessary discriminant values.
8682 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8683 values from the record are needed. Except in the case that DVAL,
8684 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8685 unchecked) is replaced by a particular branch of the variant.
8686
8687 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8688 is questionable and may be removed. It can arise during the
8689 processing of an unconstrained-array-of-record type where all the
8690 variant branches have exactly the same size. This is because in
8691 such cases, the compiler does not bother to use the XVS convention
8692 when encoding the record. I am currently dubious of this
8693 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8694
d2e4a39e 8695static struct type *
fc1a4b47 8696to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8697 CORE_ADDR address, struct value *dval)
14f9c5c9 8698{
d2e4a39e 8699 struct type *templ_type;
14f9c5c9 8700
876cecd0 8701 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8702 return type0;
8703
d2e4a39e 8704 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8705
8706 if (templ_type != NULL)
8707 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8708 else if (variant_field_index (type0) >= 0)
8709 {
8710 if (dval == NULL && valaddr == NULL && address == 0)
8711 return type0;
8712 return to_record_with_fixed_variant_part (type0, valaddr, address,
8713 dval);
8714 }
14f9c5c9
AS
8715 else
8716 {
876cecd0 8717 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8718 return type0;
8719 }
8720
8721}
8722
8723/* An ordinary record type (with fixed-length fields) that describes
8724 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8725 union type. Any necessary discriminants' values should be in DVAL,
8726 a record value. That is, this routine selects the appropriate
8727 branch of the union at ADDR according to the discriminant value
b1f33ddd 8728 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8729 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8730
d2e4a39e 8731static struct type *
fc1a4b47 8732to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8733 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8734{
8735 int which;
d2e4a39e
AS
8736 struct type *templ_type;
8737 struct type *var_type;
14f9c5c9
AS
8738
8739 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8740 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8741 else
14f9c5c9
AS
8742 var_type = var_type0;
8743
8744 templ_type = ada_find_parallel_type (var_type, "___XVU");
8745
8746 if (templ_type != NULL)
8747 var_type = templ_type;
8748
b1f33ddd
JB
8749 if (is_unchecked_variant (var_type, value_type (dval)))
8750 return var_type0;
d2e4a39e
AS
8751 which =
8752 ada_which_variant_applies (var_type,
0fd88904 8753 value_type (dval), value_contents (dval));
14f9c5c9
AS
8754
8755 if (which < 0)
e9bb382b 8756 return empty_record (var_type);
14f9c5c9 8757 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8758 return to_fixed_record_type
d2e4a39e
AS
8759 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8760 valaddr, address, dval);
4c4b4cd2 8761 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8762 return
8763 to_fixed_record_type
8764 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8765 else
8766 return TYPE_FIELD_TYPE (var_type, which);
8767}
8768
8908fca5
JB
8769/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8770 ENCODING_TYPE, a type following the GNAT conventions for discrete
8771 type encodings, only carries redundant information. */
8772
8773static int
8774ada_is_redundant_range_encoding (struct type *range_type,
8775 struct type *encoding_type)
8776{
108d56a4 8777 const char *bounds_str;
8908fca5
JB
8778 int n;
8779 LONGEST lo, hi;
8780
8781 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8782
005e2509
JB
8783 if (TYPE_CODE (get_base_type (range_type))
8784 != TYPE_CODE (get_base_type (encoding_type)))
8785 {
8786 /* The compiler probably used a simple base type to describe
8787 the range type instead of the range's actual base type,
8788 expecting us to get the real base type from the encoding
8789 anyway. In this situation, the encoding cannot be ignored
8790 as redundant. */
8791 return 0;
8792 }
8793
8908fca5
JB
8794 if (is_dynamic_type (range_type))
8795 return 0;
8796
8797 if (TYPE_NAME (encoding_type) == NULL)
8798 return 0;
8799
8800 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8801 if (bounds_str == NULL)
8802 return 0;
8803
8804 n = 8; /* Skip "___XDLU_". */
8805 if (!ada_scan_number (bounds_str, n, &lo, &n))
8806 return 0;
8807 if (TYPE_LOW_BOUND (range_type) != lo)
8808 return 0;
8809
8810 n += 2; /* Skip the "__" separator between the two bounds. */
8811 if (!ada_scan_number (bounds_str, n, &hi, &n))
8812 return 0;
8813 if (TYPE_HIGH_BOUND (range_type) != hi)
8814 return 0;
8815
8816 return 1;
8817}
8818
8819/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8820 a type following the GNAT encoding for describing array type
8821 indices, only carries redundant information. */
8822
8823static int
8824ada_is_redundant_index_type_desc (struct type *array_type,
8825 struct type *desc_type)
8826{
8827 struct type *this_layer = check_typedef (array_type);
8828 int i;
8829
8830 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8831 {
8832 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8833 TYPE_FIELD_TYPE (desc_type, i)))
8834 return 0;
8835 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8836 }
8837
8838 return 1;
8839}
8840
14f9c5c9
AS
8841/* Assuming that TYPE0 is an array type describing the type of a value
8842 at ADDR, and that DVAL describes a record containing any
8843 discriminants used in TYPE0, returns a type for the value that
8844 contains no dynamic components (that is, no components whose sizes
8845 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8846 true, gives an error message if the resulting type's size is over
4c4b4cd2 8847 varsize_limit. */
14f9c5c9 8848
d2e4a39e
AS
8849static struct type *
8850to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8851 int ignore_too_big)
14f9c5c9 8852{
d2e4a39e
AS
8853 struct type *index_type_desc;
8854 struct type *result;
ad82864c 8855 int constrained_packed_array_p;
931e5bc3 8856 static const char *xa_suffix = "___XA";
14f9c5c9 8857
b0dd7688 8858 type0 = ada_check_typedef (type0);
284614f0 8859 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8860 return type0;
14f9c5c9 8861
ad82864c
JB
8862 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8863 if (constrained_packed_array_p)
8864 type0 = decode_constrained_packed_array_type (type0);
284614f0 8865
931e5bc3
JG
8866 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8867
8868 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8869 encoding suffixed with 'P' may still be generated. If so,
8870 it should be used to find the XA type. */
8871
8872 if (index_type_desc == NULL)
8873 {
1da0522e 8874 const char *type_name = ada_type_name (type0);
931e5bc3 8875
1da0522e 8876 if (type_name != NULL)
931e5bc3 8877 {
1da0522e 8878 const int len = strlen (type_name);
931e5bc3
JG
8879 char *name = (char *) alloca (len + strlen (xa_suffix));
8880
1da0522e 8881 if (type_name[len - 1] == 'P')
931e5bc3 8882 {
1da0522e 8883 strcpy (name, type_name);
931e5bc3
JG
8884 strcpy (name + len - 1, xa_suffix);
8885 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8886 }
8887 }
8888 }
8889
28c85d6c 8890 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8891 if (index_type_desc != NULL
8892 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8893 {
8894 /* Ignore this ___XA parallel type, as it does not bring any
8895 useful information. This allows us to avoid creating fixed
8896 versions of the array's index types, which would be identical
8897 to the original ones. This, in turn, can also help avoid
8898 the creation of fixed versions of the array itself. */
8899 index_type_desc = NULL;
8900 }
8901
14f9c5c9
AS
8902 if (index_type_desc == NULL)
8903 {
61ee279c 8904 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8905
14f9c5c9 8906 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8907 depend on the contents of the array in properly constructed
8908 debugging data. */
529cad9c
PH
8909 /* Create a fixed version of the array element type.
8910 We're not providing the address of an element here,
e1d5a0d2 8911 and thus the actual object value cannot be inspected to do
529cad9c
PH
8912 the conversion. This should not be a problem, since arrays of
8913 unconstrained objects are not allowed. In particular, all
8914 the elements of an array of a tagged type should all be of
8915 the same type specified in the debugging info. No need to
8916 consult the object tag. */
1ed6ede0 8917 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8918
284614f0
JB
8919 /* Make sure we always create a new array type when dealing with
8920 packed array types, since we're going to fix-up the array
8921 type length and element bitsize a little further down. */
ad82864c 8922 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8923 result = type0;
14f9c5c9 8924 else
e9bb382b 8925 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8926 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8927 }
8928 else
8929 {
8930 int i;
8931 struct type *elt_type0;
8932
8933 elt_type0 = type0;
8934 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8935 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8936
8937 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8938 depend on the contents of the array in properly constructed
8939 debugging data. */
529cad9c
PH
8940 /* Create a fixed version of the array element type.
8941 We're not providing the address of an element here,
e1d5a0d2 8942 and thus the actual object value cannot be inspected to do
529cad9c
PH
8943 the conversion. This should not be a problem, since arrays of
8944 unconstrained objects are not allowed. In particular, all
8945 the elements of an array of a tagged type should all be of
8946 the same type specified in the debugging info. No need to
8947 consult the object tag. */
1ed6ede0
JB
8948 result =
8949 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8950
8951 elt_type0 = type0;
14f9c5c9 8952 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8953 {
8954 struct type *range_type =
28c85d6c 8955 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8956
e9bb382b 8957 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8958 result, range_type);
1ce677a4 8959 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8960 }
d2e4a39e 8961 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8962 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8963 }
8964
2e6fda7d
JB
8965 /* We want to preserve the type name. This can be useful when
8966 trying to get the type name of a value that has already been
8967 printed (for instance, if the user did "print VAR; whatis $". */
8968 TYPE_NAME (result) = TYPE_NAME (type0);
8969
ad82864c 8970 if (constrained_packed_array_p)
284614f0
JB
8971 {
8972 /* So far, the resulting type has been created as if the original
8973 type was a regular (non-packed) array type. As a result, the
8974 bitsize of the array elements needs to be set again, and the array
8975 length needs to be recomputed based on that bitsize. */
8976 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8977 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8978
8979 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8980 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8981 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8982 TYPE_LENGTH (result)++;
8983 }
8984
876cecd0 8985 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8986 return result;
d2e4a39e 8987}
14f9c5c9
AS
8988
8989
8990/* A standard type (containing no dynamically sized components)
8991 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8992 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8993 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8994 ADDRESS or in VALADDR contains these discriminants.
8995
1ed6ede0
JB
8996 If CHECK_TAG is not null, in the case of tagged types, this function
8997 attempts to locate the object's tag and use it to compute the actual
8998 type. However, when ADDRESS is null, we cannot use it to determine the
8999 location of the tag, and therefore compute the tagged type's actual type.
9000 So we return the tagged type without consulting the tag. */
529cad9c 9001
f192137b
JB
9002static struct type *
9003ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 9004 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 9005{
61ee279c 9006 type = ada_check_typedef (type);
d2e4a39e
AS
9007 switch (TYPE_CODE (type))
9008 {
9009 default:
14f9c5c9 9010 return type;
d2e4a39e 9011 case TYPE_CODE_STRUCT:
4c4b4cd2 9012 {
76a01679 9013 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
9014 struct type *fixed_record_type =
9015 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 9016
529cad9c
PH
9017 /* If STATIC_TYPE is a tagged type and we know the object's address,
9018 then we can determine its tag, and compute the object's actual
0963b4bd 9019 type from there. Note that we have to use the fixed record
1ed6ede0
JB
9020 type (the parent part of the record may have dynamic fields
9021 and the way the location of _tag is expressed may depend on
9022 them). */
529cad9c 9023
1ed6ede0 9024 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 9025 {
b50d69b5
JG
9026 struct value *tag =
9027 value_tag_from_contents_and_address
9028 (fixed_record_type,
9029 valaddr,
9030 address);
9031 struct type *real_type = type_from_tag (tag);
9032 struct value *obj =
9033 value_from_contents_and_address (fixed_record_type,
9034 valaddr,
9035 address);
9f1f738a 9036 fixed_record_type = value_type (obj);
76a01679 9037 if (real_type != NULL)
b50d69b5
JG
9038 return to_fixed_record_type
9039 (real_type, NULL,
9040 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 9041 }
4af88198
JB
9042
9043 /* Check to see if there is a parallel ___XVZ variable.
9044 If there is, then it provides the actual size of our type. */
9045 else if (ada_type_name (fixed_record_type) != NULL)
9046 {
0d5cff50 9047 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
9048 char *xvz_name
9049 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 9050 bool xvz_found = false;
4af88198
JB
9051 LONGEST size;
9052
88c15c34 9053 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
eccab96d
JB
9054 TRY
9055 {
9056 xvz_found = get_int_var_value (xvz_name, size);
9057 }
9058 CATCH (except, RETURN_MASK_ERROR)
9059 {
9060 /* We found the variable, but somehow failed to read
9061 its value. Rethrow the same error, but with a little
9062 bit more information, to help the user understand
9063 what went wrong (Eg: the variable might have been
9064 optimized out). */
9065 throw_error (except.error,
9066 _("unable to read value of %s (%s)"),
9067 xvz_name, except.message);
9068 }
9069 END_CATCH
9070
9071 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
9072 {
9073 fixed_record_type = copy_type (fixed_record_type);
9074 TYPE_LENGTH (fixed_record_type) = size;
9075
9076 /* The FIXED_RECORD_TYPE may have be a stub. We have
9077 observed this when the debugging info is STABS, and
9078 apparently it is something that is hard to fix.
9079
9080 In practice, we don't need the actual type definition
9081 at all, because the presence of the XVZ variable allows us
9082 to assume that there must be a XVS type as well, which we
9083 should be able to use later, when we need the actual type
9084 definition.
9085
9086 In the meantime, pretend that the "fixed" type we are
9087 returning is NOT a stub, because this can cause trouble
9088 when using this type to create new types targeting it.
9089 Indeed, the associated creation routines often check
9090 whether the target type is a stub and will try to replace
0963b4bd 9091 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9092 might cause the new type to have the wrong size too.
9093 Consider the case of an array, for instance, where the size
9094 of the array is computed from the number of elements in
9095 our array multiplied by the size of its element. */
9096 TYPE_STUB (fixed_record_type) = 0;
9097 }
9098 }
1ed6ede0 9099 return fixed_record_type;
4c4b4cd2 9100 }
d2e4a39e 9101 case TYPE_CODE_ARRAY:
4c4b4cd2 9102 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9103 case TYPE_CODE_UNION:
9104 if (dval == NULL)
4c4b4cd2 9105 return type;
d2e4a39e 9106 else
4c4b4cd2 9107 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9108 }
14f9c5c9
AS
9109}
9110
f192137b
JB
9111/* The same as ada_to_fixed_type_1, except that it preserves the type
9112 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9113
9114 The typedef layer needs be preserved in order to differentiate between
9115 arrays and array pointers when both types are implemented using the same
9116 fat pointer. In the array pointer case, the pointer is encoded as
9117 a typedef of the pointer type. For instance, considering:
9118
9119 type String_Access is access String;
9120 S1 : String_Access := null;
9121
9122 To the debugger, S1 is defined as a typedef of type String. But
9123 to the user, it is a pointer. So if the user tries to print S1,
9124 we should not dereference the array, but print the array address
9125 instead.
9126
9127 If we didn't preserve the typedef layer, we would lose the fact that
9128 the type is to be presented as a pointer (needs de-reference before
9129 being printed). And we would also use the source-level type name. */
f192137b
JB
9130
9131struct type *
9132ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9133 CORE_ADDR address, struct value *dval, int check_tag)
9134
9135{
9136 struct type *fixed_type =
9137 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9138
96dbd2c1
JB
9139 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9140 then preserve the typedef layer.
9141
9142 Implementation note: We can only check the main-type portion of
9143 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9144 from TYPE now returns a type that has the same instance flags
9145 as TYPE. For instance, if TYPE is a "typedef const", and its
9146 target type is a "struct", then the typedef elimination will return
9147 a "const" version of the target type. See check_typedef for more
9148 details about how the typedef layer elimination is done.
9149
9150 brobecker/2010-11-19: It seems to me that the only case where it is
9151 useful to preserve the typedef layer is when dealing with fat pointers.
9152 Perhaps, we could add a check for that and preserve the typedef layer
9153 only in that situation. But this seems unecessary so far, probably
9154 because we call check_typedef/ada_check_typedef pretty much everywhere.
9155 */
f192137b 9156 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9157 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9158 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9159 return type;
9160
9161 return fixed_type;
9162}
9163
14f9c5c9 9164/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9165 TYPE0, but based on no runtime data. */
14f9c5c9 9166
d2e4a39e
AS
9167static struct type *
9168to_static_fixed_type (struct type *type0)
14f9c5c9 9169{
d2e4a39e 9170 struct type *type;
14f9c5c9
AS
9171
9172 if (type0 == NULL)
9173 return NULL;
9174
876cecd0 9175 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9176 return type0;
9177
61ee279c 9178 type0 = ada_check_typedef (type0);
d2e4a39e 9179
14f9c5c9
AS
9180 switch (TYPE_CODE (type0))
9181 {
9182 default:
9183 return type0;
9184 case TYPE_CODE_STRUCT:
9185 type = dynamic_template_type (type0);
d2e4a39e 9186 if (type != NULL)
4c4b4cd2
PH
9187 return template_to_static_fixed_type (type);
9188 else
9189 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9190 case TYPE_CODE_UNION:
9191 type = ada_find_parallel_type (type0, "___XVU");
9192 if (type != NULL)
4c4b4cd2
PH
9193 return template_to_static_fixed_type (type);
9194 else
9195 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9196 }
9197}
9198
4c4b4cd2
PH
9199/* A static approximation of TYPE with all type wrappers removed. */
9200
d2e4a39e
AS
9201static struct type *
9202static_unwrap_type (struct type *type)
14f9c5c9
AS
9203{
9204 if (ada_is_aligner_type (type))
9205 {
61ee279c 9206 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9207 if (ada_type_name (type1) == NULL)
4c4b4cd2 9208 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9209
9210 return static_unwrap_type (type1);
9211 }
d2e4a39e 9212 else
14f9c5c9 9213 {
d2e4a39e 9214 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9215
d2e4a39e 9216 if (raw_real_type == type)
4c4b4cd2 9217 return type;
14f9c5c9 9218 else
4c4b4cd2 9219 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9220 }
9221}
9222
9223/* In some cases, incomplete and private types require
4c4b4cd2 9224 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9225 type Foo;
9226 type FooP is access Foo;
9227 V: FooP;
9228 type Foo is array ...;
4c4b4cd2 9229 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9230 cross-references to such types, we instead substitute for FooP a
9231 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9232 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9233
9234/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9235 exists, otherwise TYPE. */
9236
d2e4a39e 9237struct type *
61ee279c 9238ada_check_typedef (struct type *type)
14f9c5c9 9239{
727e3d2e
JB
9240 if (type == NULL)
9241 return NULL;
9242
720d1a40
JB
9243 /* If our type is a typedef type of a fat pointer, then we're done.
9244 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9245 what allows us to distinguish between fat pointers that represent
9246 array types, and fat pointers that represent array access types
9247 (in both cases, the compiler implements them as fat pointers). */
9248 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9249 && is_thick_pntr (ada_typedef_target_type (type)))
9250 return type;
9251
f168693b 9252 type = check_typedef (type);
14f9c5c9 9253 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9254 || !TYPE_STUB (type)
e86ca25f 9255 || TYPE_NAME (type) == NULL)
14f9c5c9 9256 return type;
d2e4a39e 9257 else
14f9c5c9 9258 {
e86ca25f 9259 const char *name = TYPE_NAME (type);
d2e4a39e 9260 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9261
05e522ef
JB
9262 if (type1 == NULL)
9263 return type;
9264
9265 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9266 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9267 types, only for the typedef-to-array types). If that's the case,
9268 strip the typedef layer. */
9269 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9270 type1 = ada_check_typedef (type1);
9271
9272 return type1;
14f9c5c9
AS
9273 }
9274}
9275
9276/* A value representing the data at VALADDR/ADDRESS as described by
9277 type TYPE0, but with a standard (static-sized) type that correctly
9278 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9279 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9280 creation of struct values]. */
14f9c5c9 9281
4c4b4cd2
PH
9282static struct value *
9283ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9284 struct value *val0)
14f9c5c9 9285{
1ed6ede0 9286 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9287
14f9c5c9
AS
9288 if (type == type0 && val0 != NULL)
9289 return val0;
cc0e770c
JB
9290
9291 if (VALUE_LVAL (val0) != lval_memory)
9292 {
9293 /* Our value does not live in memory; it could be a convenience
9294 variable, for instance. Create a not_lval value using val0's
9295 contents. */
9296 return value_from_contents (type, value_contents (val0));
9297 }
9298
9299 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9300}
9301
9302/* A value representing VAL, but with a standard (static-sized) type
9303 that correctly describes it. Does not necessarily create a new
9304 value. */
9305
0c3acc09 9306struct value *
4c4b4cd2
PH
9307ada_to_fixed_value (struct value *val)
9308{
c48db5ca
JB
9309 val = unwrap_value (val);
9310 val = ada_to_fixed_value_create (value_type (val),
9311 value_address (val),
9312 val);
9313 return val;
14f9c5c9 9314}
d2e4a39e 9315\f
14f9c5c9 9316
14f9c5c9
AS
9317/* Attributes */
9318
4c4b4cd2
PH
9319/* Table mapping attribute numbers to names.
9320 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9321
d2e4a39e 9322static const char *attribute_names[] = {
14f9c5c9
AS
9323 "<?>",
9324
d2e4a39e 9325 "first",
14f9c5c9
AS
9326 "last",
9327 "length",
9328 "image",
14f9c5c9
AS
9329 "max",
9330 "min",
4c4b4cd2
PH
9331 "modulus",
9332 "pos",
9333 "size",
9334 "tag",
14f9c5c9 9335 "val",
14f9c5c9
AS
9336 0
9337};
9338
d2e4a39e 9339const char *
4c4b4cd2 9340ada_attribute_name (enum exp_opcode n)
14f9c5c9 9341{
4c4b4cd2
PH
9342 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9343 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9344 else
9345 return attribute_names[0];
9346}
9347
4c4b4cd2 9348/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9349
4c4b4cd2
PH
9350static LONGEST
9351pos_atr (struct value *arg)
14f9c5c9 9352{
24209737
PH
9353 struct value *val = coerce_ref (arg);
9354 struct type *type = value_type (val);
aa715135 9355 LONGEST result;
14f9c5c9 9356
d2e4a39e 9357 if (!discrete_type_p (type))
323e0a4a 9358 error (_("'POS only defined on discrete types"));
14f9c5c9 9359
aa715135
JG
9360 if (!discrete_position (type, value_as_long (val), &result))
9361 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9362
aa715135 9363 return result;
4c4b4cd2
PH
9364}
9365
9366static struct value *
3cb382c9 9367value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9368{
3cb382c9 9369 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9370}
9371
4c4b4cd2 9372/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9373
d2e4a39e
AS
9374static struct value *
9375value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9376{
d2e4a39e 9377 if (!discrete_type_p (type))
323e0a4a 9378 error (_("'VAL only defined on discrete types"));
df407dfe 9379 if (!integer_type_p (value_type (arg)))
323e0a4a 9380 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9381
9382 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9383 {
9384 long pos = value_as_long (arg);
5b4ee69b 9385
14f9c5c9 9386 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9387 error (_("argument to 'VAL out of range"));
14e75d8e 9388 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9389 }
9390 else
9391 return value_from_longest (type, value_as_long (arg));
9392}
14f9c5c9 9393\f
d2e4a39e 9394
4c4b4cd2 9395 /* Evaluation */
14f9c5c9 9396
4c4b4cd2
PH
9397/* True if TYPE appears to be an Ada character type.
9398 [At the moment, this is true only for Character and Wide_Character;
9399 It is a heuristic test that could stand improvement]. */
14f9c5c9 9400
d2e4a39e
AS
9401int
9402ada_is_character_type (struct type *type)
14f9c5c9 9403{
7b9f71f2
JB
9404 const char *name;
9405
9406 /* If the type code says it's a character, then assume it really is,
9407 and don't check any further. */
9408 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9409 return 1;
9410
9411 /* Otherwise, assume it's a character type iff it is a discrete type
9412 with a known character type name. */
9413 name = ada_type_name (type);
9414 return (name != NULL
9415 && (TYPE_CODE (type) == TYPE_CODE_INT
9416 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9417 && (strcmp (name, "character") == 0
9418 || strcmp (name, "wide_character") == 0
5a517ebd 9419 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9420 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9421}
9422
4c4b4cd2 9423/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9424
9425int
ebf56fd3 9426ada_is_string_type (struct type *type)
14f9c5c9 9427{
61ee279c 9428 type = ada_check_typedef (type);
d2e4a39e 9429 if (type != NULL
14f9c5c9 9430 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9431 && (ada_is_simple_array_type (type)
9432 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9433 && ada_array_arity (type) == 1)
9434 {
9435 struct type *elttype = ada_array_element_type (type, 1);
9436
9437 return ada_is_character_type (elttype);
9438 }
d2e4a39e 9439 else
14f9c5c9
AS
9440 return 0;
9441}
9442
5bf03f13
JB
9443/* The compiler sometimes provides a parallel XVS type for a given
9444 PAD type. Normally, it is safe to follow the PAD type directly,
9445 but older versions of the compiler have a bug that causes the offset
9446 of its "F" field to be wrong. Following that field in that case
9447 would lead to incorrect results, but this can be worked around
9448 by ignoring the PAD type and using the associated XVS type instead.
9449
9450 Set to True if the debugger should trust the contents of PAD types.
9451 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9452static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9453
9454/* True if TYPE is a struct type introduced by the compiler to force the
9455 alignment of a value. Such types have a single field with a
4c4b4cd2 9456 distinctive name. */
14f9c5c9
AS
9457
9458int
ebf56fd3 9459ada_is_aligner_type (struct type *type)
14f9c5c9 9460{
61ee279c 9461 type = ada_check_typedef (type);
714e53ab 9462
5bf03f13 9463 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9464 return 0;
9465
14f9c5c9 9466 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9467 && TYPE_NFIELDS (type) == 1
9468 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9469}
9470
9471/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9472 the parallel type. */
14f9c5c9 9473
d2e4a39e
AS
9474struct type *
9475ada_get_base_type (struct type *raw_type)
14f9c5c9 9476{
d2e4a39e
AS
9477 struct type *real_type_namer;
9478 struct type *raw_real_type;
14f9c5c9
AS
9479
9480 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9481 return raw_type;
9482
284614f0
JB
9483 if (ada_is_aligner_type (raw_type))
9484 /* The encoding specifies that we should always use the aligner type.
9485 So, even if this aligner type has an associated XVS type, we should
9486 simply ignore it.
9487
9488 According to the compiler gurus, an XVS type parallel to an aligner
9489 type may exist because of a stabs limitation. In stabs, aligner
9490 types are empty because the field has a variable-sized type, and
9491 thus cannot actually be used as an aligner type. As a result,
9492 we need the associated parallel XVS type to decode the type.
9493 Since the policy in the compiler is to not change the internal
9494 representation based on the debugging info format, we sometimes
9495 end up having a redundant XVS type parallel to the aligner type. */
9496 return raw_type;
9497
14f9c5c9 9498 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9499 if (real_type_namer == NULL
14f9c5c9
AS
9500 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9501 || TYPE_NFIELDS (real_type_namer) != 1)
9502 return raw_type;
9503
f80d3ff2
JB
9504 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9505 {
9506 /* This is an older encoding form where the base type needs to be
9507 looked up by name. We prefer the newer enconding because it is
9508 more efficient. */
9509 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9510 if (raw_real_type == NULL)
9511 return raw_type;
9512 else
9513 return raw_real_type;
9514 }
9515
9516 /* The field in our XVS type is a reference to the base type. */
9517 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9518}
14f9c5c9 9519
4c4b4cd2 9520/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9521
d2e4a39e
AS
9522struct type *
9523ada_aligned_type (struct type *type)
14f9c5c9
AS
9524{
9525 if (ada_is_aligner_type (type))
9526 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9527 else
9528 return ada_get_base_type (type);
9529}
9530
9531
9532/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9533 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9534
fc1a4b47
AC
9535const gdb_byte *
9536ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9537{
d2e4a39e 9538 if (ada_is_aligner_type (type))
14f9c5c9 9539 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9540 valaddr +
9541 TYPE_FIELD_BITPOS (type,
9542 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9543 else
9544 return valaddr;
9545}
9546
4c4b4cd2
PH
9547
9548
14f9c5c9 9549/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9550 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9551const char *
9552ada_enum_name (const char *name)
14f9c5c9 9553{
4c4b4cd2
PH
9554 static char *result;
9555 static size_t result_len = 0;
e6a959d6 9556 const char *tmp;
14f9c5c9 9557
4c4b4cd2
PH
9558 /* First, unqualify the enumeration name:
9559 1. Search for the last '.' character. If we find one, then skip
177b42fe 9560 all the preceding characters, the unqualified name starts
76a01679 9561 right after that dot.
4c4b4cd2 9562 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9563 translates dots into "__". Search forward for double underscores,
9564 but stop searching when we hit an overloading suffix, which is
9565 of the form "__" followed by digits. */
4c4b4cd2 9566
c3e5cd34
PH
9567 tmp = strrchr (name, '.');
9568 if (tmp != NULL)
4c4b4cd2
PH
9569 name = tmp + 1;
9570 else
14f9c5c9 9571 {
4c4b4cd2
PH
9572 while ((tmp = strstr (name, "__")) != NULL)
9573 {
9574 if (isdigit (tmp[2]))
9575 break;
9576 else
9577 name = tmp + 2;
9578 }
14f9c5c9
AS
9579 }
9580
9581 if (name[0] == 'Q')
9582 {
14f9c5c9 9583 int v;
5b4ee69b 9584
14f9c5c9 9585 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9586 {
9587 if (sscanf (name + 2, "%x", &v) != 1)
9588 return name;
9589 }
14f9c5c9 9590 else
4c4b4cd2 9591 return name;
14f9c5c9 9592
4c4b4cd2 9593 GROW_VECT (result, result_len, 16);
14f9c5c9 9594 if (isascii (v) && isprint (v))
88c15c34 9595 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9596 else if (name[1] == 'U')
88c15c34 9597 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9598 else
88c15c34 9599 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9600
9601 return result;
9602 }
d2e4a39e 9603 else
4c4b4cd2 9604 {
c3e5cd34
PH
9605 tmp = strstr (name, "__");
9606 if (tmp == NULL)
9607 tmp = strstr (name, "$");
9608 if (tmp != NULL)
4c4b4cd2
PH
9609 {
9610 GROW_VECT (result, result_len, tmp - name + 1);
9611 strncpy (result, name, tmp - name);
9612 result[tmp - name] = '\0';
9613 return result;
9614 }
9615
9616 return name;
9617 }
14f9c5c9
AS
9618}
9619
14f9c5c9
AS
9620/* Evaluate the subexpression of EXP starting at *POS as for
9621 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9622 expression. */
14f9c5c9 9623
d2e4a39e
AS
9624static struct value *
9625evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9626{
4b27a620 9627 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9628}
9629
9630/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9631 value it wraps. */
14f9c5c9 9632
d2e4a39e
AS
9633static struct value *
9634unwrap_value (struct value *val)
14f9c5c9 9635{
df407dfe 9636 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9637
14f9c5c9
AS
9638 if (ada_is_aligner_type (type))
9639 {
de4d072f 9640 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9641 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9642
14f9c5c9 9643 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9644 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9645
9646 return unwrap_value (v);
9647 }
d2e4a39e 9648 else
14f9c5c9 9649 {
d2e4a39e 9650 struct type *raw_real_type =
61ee279c 9651 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9652
5bf03f13
JB
9653 /* If there is no parallel XVS or XVE type, then the value is
9654 already unwrapped. Return it without further modification. */
9655 if ((type == raw_real_type)
9656 && ada_find_parallel_type (type, "___XVE") == NULL)
9657 return val;
14f9c5c9 9658
d2e4a39e 9659 return
4c4b4cd2
PH
9660 coerce_unspec_val_to_type
9661 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9662 value_address (val),
1ed6ede0 9663 NULL, 1));
14f9c5c9
AS
9664 }
9665}
d2e4a39e
AS
9666
9667static struct value *
50eff16b 9668cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9669{
50eff16b
UW
9670 struct value *scale = ada_scaling_factor (value_type (arg));
9671 arg = value_cast (value_type (scale), arg);
14f9c5c9 9672
50eff16b
UW
9673 arg = value_binop (arg, scale, BINOP_MUL);
9674 return value_cast (type, arg);
14f9c5c9
AS
9675}
9676
d2e4a39e 9677static struct value *
50eff16b 9678cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9679{
50eff16b
UW
9680 if (type == value_type (arg))
9681 return arg;
5b4ee69b 9682
50eff16b
UW
9683 struct value *scale = ada_scaling_factor (type);
9684 if (ada_is_fixed_point_type (value_type (arg)))
9685 arg = cast_from_fixed (value_type (scale), arg);
9686 else
9687 arg = value_cast (value_type (scale), arg);
9688
9689 arg = value_binop (arg, scale, BINOP_DIV);
9690 return value_cast (type, arg);
14f9c5c9
AS
9691}
9692
d99dcf51
JB
9693/* Given two array types T1 and T2, return nonzero iff both arrays
9694 contain the same number of elements. */
9695
9696static int
9697ada_same_array_size_p (struct type *t1, struct type *t2)
9698{
9699 LONGEST lo1, hi1, lo2, hi2;
9700
9701 /* Get the array bounds in order to verify that the size of
9702 the two arrays match. */
9703 if (!get_array_bounds (t1, &lo1, &hi1)
9704 || !get_array_bounds (t2, &lo2, &hi2))
9705 error (_("unable to determine array bounds"));
9706
9707 /* To make things easier for size comparison, normalize a bit
9708 the case of empty arrays by making sure that the difference
9709 between upper bound and lower bound is always -1. */
9710 if (lo1 > hi1)
9711 hi1 = lo1 - 1;
9712 if (lo2 > hi2)
9713 hi2 = lo2 - 1;
9714
9715 return (hi1 - lo1 == hi2 - lo2);
9716}
9717
9718/* Assuming that VAL is an array of integrals, and TYPE represents
9719 an array with the same number of elements, but with wider integral
9720 elements, return an array "casted" to TYPE. In practice, this
9721 means that the returned array is built by casting each element
9722 of the original array into TYPE's (wider) element type. */
9723
9724static struct value *
9725ada_promote_array_of_integrals (struct type *type, struct value *val)
9726{
9727 struct type *elt_type = TYPE_TARGET_TYPE (type);
9728 LONGEST lo, hi;
9729 struct value *res;
9730 LONGEST i;
9731
9732 /* Verify that both val and type are arrays of scalars, and
9733 that the size of val's elements is smaller than the size
9734 of type's element. */
9735 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9736 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9737 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9738 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9739 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9740 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9741
9742 if (!get_array_bounds (type, &lo, &hi))
9743 error (_("unable to determine array bounds"));
9744
9745 res = allocate_value (type);
9746
9747 /* Promote each array element. */
9748 for (i = 0; i < hi - lo + 1; i++)
9749 {
9750 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9751
9752 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9753 value_contents_all (elt), TYPE_LENGTH (elt_type));
9754 }
9755
9756 return res;
9757}
9758
4c4b4cd2
PH
9759/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9760 return the converted value. */
9761
d2e4a39e
AS
9762static struct value *
9763coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9764{
df407dfe 9765 struct type *type2 = value_type (val);
5b4ee69b 9766
14f9c5c9
AS
9767 if (type == type2)
9768 return val;
9769
61ee279c
PH
9770 type2 = ada_check_typedef (type2);
9771 type = ada_check_typedef (type);
14f9c5c9 9772
d2e4a39e
AS
9773 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9774 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9775 {
9776 val = ada_value_ind (val);
df407dfe 9777 type2 = value_type (val);
14f9c5c9
AS
9778 }
9779
d2e4a39e 9780 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9781 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9782 {
d99dcf51
JB
9783 if (!ada_same_array_size_p (type, type2))
9784 error (_("cannot assign arrays of different length"));
9785
9786 if (is_integral_type (TYPE_TARGET_TYPE (type))
9787 && is_integral_type (TYPE_TARGET_TYPE (type2))
9788 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9789 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9790 {
9791 /* Allow implicit promotion of the array elements to
9792 a wider type. */
9793 return ada_promote_array_of_integrals (type, val);
9794 }
9795
9796 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9797 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9798 error (_("Incompatible types in assignment"));
04624583 9799 deprecated_set_value_type (val, type);
14f9c5c9 9800 }
d2e4a39e 9801 return val;
14f9c5c9
AS
9802}
9803
4c4b4cd2
PH
9804static struct value *
9805ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9806{
9807 struct value *val;
9808 struct type *type1, *type2;
9809 LONGEST v, v1, v2;
9810
994b9211
AC
9811 arg1 = coerce_ref (arg1);
9812 arg2 = coerce_ref (arg2);
18af8284
JB
9813 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9814 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9815
76a01679
JB
9816 if (TYPE_CODE (type1) != TYPE_CODE_INT
9817 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9818 return value_binop (arg1, arg2, op);
9819
76a01679 9820 switch (op)
4c4b4cd2
PH
9821 {
9822 case BINOP_MOD:
9823 case BINOP_DIV:
9824 case BINOP_REM:
9825 break;
9826 default:
9827 return value_binop (arg1, arg2, op);
9828 }
9829
9830 v2 = value_as_long (arg2);
9831 if (v2 == 0)
323e0a4a 9832 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9833
9834 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9835 return value_binop (arg1, arg2, op);
9836
9837 v1 = value_as_long (arg1);
9838 switch (op)
9839 {
9840 case BINOP_DIV:
9841 v = v1 / v2;
76a01679
JB
9842 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9843 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9844 break;
9845 case BINOP_REM:
9846 v = v1 % v2;
76a01679
JB
9847 if (v * v1 < 0)
9848 v -= v2;
4c4b4cd2
PH
9849 break;
9850 default:
9851 /* Should not reach this point. */
9852 v = 0;
9853 }
9854
9855 val = allocate_value (type1);
990a07ab 9856 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9857 TYPE_LENGTH (value_type (val)),
9858 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9859 return val;
9860}
9861
9862static int
9863ada_value_equal (struct value *arg1, struct value *arg2)
9864{
df407dfe
AC
9865 if (ada_is_direct_array_type (value_type (arg1))
9866 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9867 {
79e8fcaa
JB
9868 struct type *arg1_type, *arg2_type;
9869
f58b38bf
JB
9870 /* Automatically dereference any array reference before
9871 we attempt to perform the comparison. */
9872 arg1 = ada_coerce_ref (arg1);
9873 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9874
4c4b4cd2
PH
9875 arg1 = ada_coerce_to_simple_array (arg1);
9876 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9877
9878 arg1_type = ada_check_typedef (value_type (arg1));
9879 arg2_type = ada_check_typedef (value_type (arg2));
9880
9881 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9882 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9883 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9884 /* FIXME: The following works only for types whose
76a01679
JB
9885 representations use all bits (no padding or undefined bits)
9886 and do not have user-defined equality. */
79e8fcaa
JB
9887 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9888 && memcmp (value_contents (arg1), value_contents (arg2),
9889 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9890 }
9891 return value_equal (arg1, arg2);
9892}
9893
52ce6436
PH
9894/* Total number of component associations in the aggregate starting at
9895 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9896 OP_AGGREGATE. */
52ce6436
PH
9897
9898static int
9899num_component_specs (struct expression *exp, int pc)
9900{
9901 int n, m, i;
5b4ee69b 9902
52ce6436
PH
9903 m = exp->elts[pc + 1].longconst;
9904 pc += 3;
9905 n = 0;
9906 for (i = 0; i < m; i += 1)
9907 {
9908 switch (exp->elts[pc].opcode)
9909 {
9910 default:
9911 n += 1;
9912 break;
9913 case OP_CHOICES:
9914 n += exp->elts[pc + 1].longconst;
9915 break;
9916 }
9917 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9918 }
9919 return n;
9920}
9921
9922/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9923 component of LHS (a simple array or a record), updating *POS past
9924 the expression, assuming that LHS is contained in CONTAINER. Does
9925 not modify the inferior's memory, nor does it modify LHS (unless
9926 LHS == CONTAINER). */
9927
9928static void
9929assign_component (struct value *container, struct value *lhs, LONGEST index,
9930 struct expression *exp, int *pos)
9931{
9932 struct value *mark = value_mark ();
9933 struct value *elt;
0e2da9f0 9934 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9935
0e2da9f0 9936 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9937 {
22601c15
UW
9938 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9939 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9940
52ce6436
PH
9941 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9942 }
9943 else
9944 {
9945 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9946 elt = ada_to_fixed_value (elt);
52ce6436
PH
9947 }
9948
9949 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9950 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9951 else
9952 value_assign_to_component (container, elt,
9953 ada_evaluate_subexp (NULL, exp, pos,
9954 EVAL_NORMAL));
9955
9956 value_free_to_mark (mark);
9957}
9958
9959/* Assuming that LHS represents an lvalue having a record or array
9960 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9961 of that aggregate's value to LHS, advancing *POS past the
9962 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9963 lvalue containing LHS (possibly LHS itself). Does not modify
9964 the inferior's memory, nor does it modify the contents of
0963b4bd 9965 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9966
9967static struct value *
9968assign_aggregate (struct value *container,
9969 struct value *lhs, struct expression *exp,
9970 int *pos, enum noside noside)
9971{
9972 struct type *lhs_type;
9973 int n = exp->elts[*pos+1].longconst;
9974 LONGEST low_index, high_index;
9975 int num_specs;
9976 LONGEST *indices;
9977 int max_indices, num_indices;
52ce6436 9978 int i;
52ce6436
PH
9979
9980 *pos += 3;
9981 if (noside != EVAL_NORMAL)
9982 {
52ce6436
PH
9983 for (i = 0; i < n; i += 1)
9984 ada_evaluate_subexp (NULL, exp, pos, noside);
9985 return container;
9986 }
9987
9988 container = ada_coerce_ref (container);
9989 if (ada_is_direct_array_type (value_type (container)))
9990 container = ada_coerce_to_simple_array (container);
9991 lhs = ada_coerce_ref (lhs);
9992 if (!deprecated_value_modifiable (lhs))
9993 error (_("Left operand of assignment is not a modifiable lvalue."));
9994
0e2da9f0 9995 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9996 if (ada_is_direct_array_type (lhs_type))
9997 {
9998 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 9999 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
10000 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10001 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
10002 }
10003 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10004 {
10005 low_index = 0;
10006 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
10007 }
10008 else
10009 error (_("Left-hand side must be array or record."));
10010
10011 num_specs = num_component_specs (exp, *pos - 3);
10012 max_indices = 4 * num_specs + 4;
8d749320 10013 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
10014 indices[0] = indices[1] = low_index - 1;
10015 indices[2] = indices[3] = high_index + 1;
10016 num_indices = 4;
10017
10018 for (i = 0; i < n; i += 1)
10019 {
10020 switch (exp->elts[*pos].opcode)
10021 {
1fbf5ada
JB
10022 case OP_CHOICES:
10023 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10024 &num_indices, max_indices,
10025 low_index, high_index);
10026 break;
10027 case OP_POSITIONAL:
10028 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
10029 &num_indices, max_indices,
10030 low_index, high_index);
1fbf5ada
JB
10031 break;
10032 case OP_OTHERS:
10033 if (i != n-1)
10034 error (_("Misplaced 'others' clause"));
10035 aggregate_assign_others (container, lhs, exp, pos, indices,
10036 num_indices, low_index, high_index);
10037 break;
10038 default:
10039 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
10040 }
10041 }
10042
10043 return container;
10044}
10045
10046/* Assign into the component of LHS indexed by the OP_POSITIONAL
10047 construct at *POS, updating *POS past the construct, given that
10048 the positions are relative to lower bound LOW, where HIGH is the
10049 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10050 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 10051 assign_aggregate. */
52ce6436
PH
10052static void
10053aggregate_assign_positional (struct value *container,
10054 struct value *lhs, struct expression *exp,
10055 int *pos, LONGEST *indices, int *num_indices,
10056 int max_indices, LONGEST low, LONGEST high)
10057{
10058 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10059
10060 if (ind - 1 == high)
e1d5a0d2 10061 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
10062 if (ind <= high)
10063 {
10064 add_component_interval (ind, ind, indices, num_indices, max_indices);
10065 *pos += 3;
10066 assign_component (container, lhs, ind, exp, pos);
10067 }
10068 else
10069 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10070}
10071
10072/* Assign into the components of LHS indexed by the OP_CHOICES
10073 construct at *POS, updating *POS past the construct, given that
10074 the allowable indices are LOW..HIGH. Record the indices assigned
10075 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 10076 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10077static void
10078aggregate_assign_from_choices (struct value *container,
10079 struct value *lhs, struct expression *exp,
10080 int *pos, LONGEST *indices, int *num_indices,
10081 int max_indices, LONGEST low, LONGEST high)
10082{
10083 int j;
10084 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10085 int choice_pos, expr_pc;
10086 int is_array = ada_is_direct_array_type (value_type (lhs));
10087
10088 choice_pos = *pos += 3;
10089
10090 for (j = 0; j < n_choices; j += 1)
10091 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10092 expr_pc = *pos;
10093 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10094
10095 for (j = 0; j < n_choices; j += 1)
10096 {
10097 LONGEST lower, upper;
10098 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10099
52ce6436
PH
10100 if (op == OP_DISCRETE_RANGE)
10101 {
10102 choice_pos += 1;
10103 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10104 EVAL_NORMAL));
10105 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10106 EVAL_NORMAL));
10107 }
10108 else if (is_array)
10109 {
10110 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10111 EVAL_NORMAL));
10112 upper = lower;
10113 }
10114 else
10115 {
10116 int ind;
0d5cff50 10117 const char *name;
5b4ee69b 10118
52ce6436
PH
10119 switch (op)
10120 {
10121 case OP_NAME:
10122 name = &exp->elts[choice_pos + 2].string;
10123 break;
10124 case OP_VAR_VALUE:
10125 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10126 break;
10127 default:
10128 error (_("Invalid record component association."));
10129 }
10130 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10131 ind = 0;
10132 if (! find_struct_field (name, value_type (lhs), 0,
10133 NULL, NULL, NULL, NULL, &ind))
10134 error (_("Unknown component name: %s."), name);
10135 lower = upper = ind;
10136 }
10137
10138 if (lower <= upper && (lower < low || upper > high))
10139 error (_("Index in component association out of bounds."));
10140
10141 add_component_interval (lower, upper, indices, num_indices,
10142 max_indices);
10143 while (lower <= upper)
10144 {
10145 int pos1;
5b4ee69b 10146
52ce6436
PH
10147 pos1 = expr_pc;
10148 assign_component (container, lhs, lower, exp, &pos1);
10149 lower += 1;
10150 }
10151 }
10152}
10153
10154/* Assign the value of the expression in the OP_OTHERS construct in
10155 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10156 have not been previously assigned. The index intervals already assigned
10157 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10158 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10159static void
10160aggregate_assign_others (struct value *container,
10161 struct value *lhs, struct expression *exp,
10162 int *pos, LONGEST *indices, int num_indices,
10163 LONGEST low, LONGEST high)
10164{
10165 int i;
5ce64950 10166 int expr_pc = *pos + 1;
52ce6436
PH
10167
10168 for (i = 0; i < num_indices - 2; i += 2)
10169 {
10170 LONGEST ind;
5b4ee69b 10171
52ce6436
PH
10172 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10173 {
5ce64950 10174 int localpos;
5b4ee69b 10175
5ce64950
MS
10176 localpos = expr_pc;
10177 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10178 }
10179 }
10180 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10181}
10182
10183/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10184 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10185 modifying *SIZE as needed. It is an error if *SIZE exceeds
10186 MAX_SIZE. The resulting intervals do not overlap. */
10187static void
10188add_component_interval (LONGEST low, LONGEST high,
10189 LONGEST* indices, int *size, int max_size)
10190{
10191 int i, j;
5b4ee69b 10192
52ce6436
PH
10193 for (i = 0; i < *size; i += 2) {
10194 if (high >= indices[i] && low <= indices[i + 1])
10195 {
10196 int kh;
5b4ee69b 10197
52ce6436
PH
10198 for (kh = i + 2; kh < *size; kh += 2)
10199 if (high < indices[kh])
10200 break;
10201 if (low < indices[i])
10202 indices[i] = low;
10203 indices[i + 1] = indices[kh - 1];
10204 if (high > indices[i + 1])
10205 indices[i + 1] = high;
10206 memcpy (indices + i + 2, indices + kh, *size - kh);
10207 *size -= kh - i - 2;
10208 return;
10209 }
10210 else if (high < indices[i])
10211 break;
10212 }
10213
10214 if (*size == max_size)
10215 error (_("Internal error: miscounted aggregate components."));
10216 *size += 2;
10217 for (j = *size-1; j >= i+2; j -= 1)
10218 indices[j] = indices[j - 2];
10219 indices[i] = low;
10220 indices[i + 1] = high;
10221}
10222
6e48bd2c
JB
10223/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10224 is different. */
10225
10226static struct value *
b7e22850 10227ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10228{
10229 if (type == ada_check_typedef (value_type (arg2)))
10230 return arg2;
10231
10232 if (ada_is_fixed_point_type (type))
10233 return (cast_to_fixed (type, arg2));
10234
10235 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10236 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10237
10238 return value_cast (type, arg2);
10239}
10240
284614f0
JB
10241/* Evaluating Ada expressions, and printing their result.
10242 ------------------------------------------------------
10243
21649b50
JB
10244 1. Introduction:
10245 ----------------
10246
284614f0
JB
10247 We usually evaluate an Ada expression in order to print its value.
10248 We also evaluate an expression in order to print its type, which
10249 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10250 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10251 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10252 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10253 similar.
10254
10255 Evaluating expressions is a little more complicated for Ada entities
10256 than it is for entities in languages such as C. The main reason for
10257 this is that Ada provides types whose definition might be dynamic.
10258 One example of such types is variant records. Or another example
10259 would be an array whose bounds can only be known at run time.
10260
10261 The following description is a general guide as to what should be
10262 done (and what should NOT be done) in order to evaluate an expression
10263 involving such types, and when. This does not cover how the semantic
10264 information is encoded by GNAT as this is covered separatly. For the
10265 document used as the reference for the GNAT encoding, see exp_dbug.ads
10266 in the GNAT sources.
10267
10268 Ideally, we should embed each part of this description next to its
10269 associated code. Unfortunately, the amount of code is so vast right
10270 now that it's hard to see whether the code handling a particular
10271 situation might be duplicated or not. One day, when the code is
10272 cleaned up, this guide might become redundant with the comments
10273 inserted in the code, and we might want to remove it.
10274
21649b50
JB
10275 2. ``Fixing'' an Entity, the Simple Case:
10276 -----------------------------------------
10277
284614f0
JB
10278 When evaluating Ada expressions, the tricky issue is that they may
10279 reference entities whose type contents and size are not statically
10280 known. Consider for instance a variant record:
10281
10282 type Rec (Empty : Boolean := True) is record
10283 case Empty is
10284 when True => null;
10285 when False => Value : Integer;
10286 end case;
10287 end record;
10288 Yes : Rec := (Empty => False, Value => 1);
10289 No : Rec := (empty => True);
10290
10291 The size and contents of that record depends on the value of the
10292 descriminant (Rec.Empty). At this point, neither the debugging
10293 information nor the associated type structure in GDB are able to
10294 express such dynamic types. So what the debugger does is to create
10295 "fixed" versions of the type that applies to the specific object.
10296 We also informally refer to this opperation as "fixing" an object,
10297 which means creating its associated fixed type.
10298
10299 Example: when printing the value of variable "Yes" above, its fixed
10300 type would look like this:
10301
10302 type Rec is record
10303 Empty : Boolean;
10304 Value : Integer;
10305 end record;
10306
10307 On the other hand, if we printed the value of "No", its fixed type
10308 would become:
10309
10310 type Rec is record
10311 Empty : Boolean;
10312 end record;
10313
10314 Things become a little more complicated when trying to fix an entity
10315 with a dynamic type that directly contains another dynamic type,
10316 such as an array of variant records, for instance. There are
10317 two possible cases: Arrays, and records.
10318
21649b50
JB
10319 3. ``Fixing'' Arrays:
10320 ---------------------
10321
10322 The type structure in GDB describes an array in terms of its bounds,
10323 and the type of its elements. By design, all elements in the array
10324 have the same type and we cannot represent an array of variant elements
10325 using the current type structure in GDB. When fixing an array,
10326 we cannot fix the array element, as we would potentially need one
10327 fixed type per element of the array. As a result, the best we can do
10328 when fixing an array is to produce an array whose bounds and size
10329 are correct (allowing us to read it from memory), but without having
10330 touched its element type. Fixing each element will be done later,
10331 when (if) necessary.
10332
10333 Arrays are a little simpler to handle than records, because the same
10334 amount of memory is allocated for each element of the array, even if
1b536f04 10335 the amount of space actually used by each element differs from element
21649b50 10336 to element. Consider for instance the following array of type Rec:
284614f0
JB
10337
10338 type Rec_Array is array (1 .. 2) of Rec;
10339
1b536f04
JB
10340 The actual amount of memory occupied by each element might be different
10341 from element to element, depending on the value of their discriminant.
21649b50 10342 But the amount of space reserved for each element in the array remains
1b536f04 10343 fixed regardless. So we simply need to compute that size using
21649b50
JB
10344 the debugging information available, from which we can then determine
10345 the array size (we multiply the number of elements of the array by
10346 the size of each element).
10347
10348 The simplest case is when we have an array of a constrained element
10349 type. For instance, consider the following type declarations:
10350
10351 type Bounded_String (Max_Size : Integer) is
10352 Length : Integer;
10353 Buffer : String (1 .. Max_Size);
10354 end record;
10355 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10356
10357 In this case, the compiler describes the array as an array of
10358 variable-size elements (identified by its XVS suffix) for which
10359 the size can be read in the parallel XVZ variable.
10360
10361 In the case of an array of an unconstrained element type, the compiler
10362 wraps the array element inside a private PAD type. This type should not
10363 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10364 that we also use the adjective "aligner" in our code to designate
10365 these wrapper types.
10366
1b536f04 10367 In some cases, the size allocated for each element is statically
21649b50
JB
10368 known. In that case, the PAD type already has the correct size,
10369 and the array element should remain unfixed.
10370
10371 But there are cases when this size is not statically known.
10372 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10373
10374 type Dynamic is array (1 .. Five) of Integer;
10375 type Wrapper (Has_Length : Boolean := False) is record
10376 Data : Dynamic;
10377 case Has_Length is
10378 when True => Length : Integer;
10379 when False => null;
10380 end case;
10381 end record;
10382 type Wrapper_Array is array (1 .. 2) of Wrapper;
10383
10384 Hello : Wrapper_Array := (others => (Has_Length => True,
10385 Data => (others => 17),
10386 Length => 1));
10387
10388
10389 The debugging info would describe variable Hello as being an
10390 array of a PAD type. The size of that PAD type is not statically
10391 known, but can be determined using a parallel XVZ variable.
10392 In that case, a copy of the PAD type with the correct size should
10393 be used for the fixed array.
10394
21649b50
JB
10395 3. ``Fixing'' record type objects:
10396 ----------------------------------
10397
10398 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10399 record types. In this case, in order to compute the associated
10400 fixed type, we need to determine the size and offset of each of
10401 its components. This, in turn, requires us to compute the fixed
10402 type of each of these components.
10403
10404 Consider for instance the example:
10405
10406 type Bounded_String (Max_Size : Natural) is record
10407 Str : String (1 .. Max_Size);
10408 Length : Natural;
10409 end record;
10410 My_String : Bounded_String (Max_Size => 10);
10411
10412 In that case, the position of field "Length" depends on the size
10413 of field Str, which itself depends on the value of the Max_Size
21649b50 10414 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10415 we need to fix the type of field Str. Therefore, fixing a variant
10416 record requires us to fix each of its components.
10417
10418 However, if a component does not have a dynamic size, the component
10419 should not be fixed. In particular, fields that use a PAD type
10420 should not fixed. Here is an example where this might happen
10421 (assuming type Rec above):
10422
10423 type Container (Big : Boolean) is record
10424 First : Rec;
10425 After : Integer;
10426 case Big is
10427 when True => Another : Integer;
10428 when False => null;
10429 end case;
10430 end record;
10431 My_Container : Container := (Big => False,
10432 First => (Empty => True),
10433 After => 42);
10434
10435 In that example, the compiler creates a PAD type for component First,
10436 whose size is constant, and then positions the component After just
10437 right after it. The offset of component After is therefore constant
10438 in this case.
10439
10440 The debugger computes the position of each field based on an algorithm
10441 that uses, among other things, the actual position and size of the field
21649b50
JB
10442 preceding it. Let's now imagine that the user is trying to print
10443 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10444 end up computing the offset of field After based on the size of the
10445 fixed version of field First. And since in our example First has
10446 only one actual field, the size of the fixed type is actually smaller
10447 than the amount of space allocated to that field, and thus we would
10448 compute the wrong offset of field After.
10449
21649b50
JB
10450 To make things more complicated, we need to watch out for dynamic
10451 components of variant records (identified by the ___XVL suffix in
10452 the component name). Even if the target type is a PAD type, the size
10453 of that type might not be statically known. So the PAD type needs
10454 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10455 we might end up with the wrong size for our component. This can be
10456 observed with the following type declarations:
284614f0
JB
10457
10458 type Octal is new Integer range 0 .. 7;
10459 type Octal_Array is array (Positive range <>) of Octal;
10460 pragma Pack (Octal_Array);
10461
10462 type Octal_Buffer (Size : Positive) is record
10463 Buffer : Octal_Array (1 .. Size);
10464 Length : Integer;
10465 end record;
10466
10467 In that case, Buffer is a PAD type whose size is unset and needs
10468 to be computed by fixing the unwrapped type.
10469
21649b50
JB
10470 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10471 ----------------------------------------------------------
10472
10473 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10474 thus far, be actually fixed?
10475
10476 The answer is: Only when referencing that element. For instance
10477 when selecting one component of a record, this specific component
10478 should be fixed at that point in time. Or when printing the value
10479 of a record, each component should be fixed before its value gets
10480 printed. Similarly for arrays, the element of the array should be
10481 fixed when printing each element of the array, or when extracting
10482 one element out of that array. On the other hand, fixing should
10483 not be performed on the elements when taking a slice of an array!
10484
31432a67 10485 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10486 size of each field is that we end up also miscomputing the size
10487 of the containing type. This can have adverse results when computing
10488 the value of an entity. GDB fetches the value of an entity based
10489 on the size of its type, and thus a wrong size causes GDB to fetch
10490 the wrong amount of memory. In the case where the computed size is
10491 too small, GDB fetches too little data to print the value of our
31432a67 10492 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10493 past the buffer containing the data =:-o. */
10494
ced9779b
JB
10495/* Evaluate a subexpression of EXP, at index *POS, and return a value
10496 for that subexpression cast to TO_TYPE. Advance *POS over the
10497 subexpression. */
10498
10499static value *
10500ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10501 enum noside noside, struct type *to_type)
10502{
10503 int pc = *pos;
10504
10505 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10506 || exp->elts[pc].opcode == OP_VAR_VALUE)
10507 {
10508 (*pos) += 4;
10509
10510 value *val;
10511 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10512 {
10513 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10514 return value_zero (to_type, not_lval);
10515
10516 val = evaluate_var_msym_value (noside,
10517 exp->elts[pc + 1].objfile,
10518 exp->elts[pc + 2].msymbol);
10519 }
10520 else
10521 val = evaluate_var_value (noside,
10522 exp->elts[pc + 1].block,
10523 exp->elts[pc + 2].symbol);
10524
10525 if (noside == EVAL_SKIP)
10526 return eval_skip_value (exp);
10527
10528 val = ada_value_cast (to_type, val);
10529
10530 /* Follow the Ada language semantics that do not allow taking
10531 an address of the result of a cast (view conversion in Ada). */
10532 if (VALUE_LVAL (val) == lval_memory)
10533 {
10534 if (value_lazy (val))
10535 value_fetch_lazy (val);
10536 VALUE_LVAL (val) = not_lval;
10537 }
10538 return val;
10539 }
10540
10541 value *val = evaluate_subexp (to_type, exp, pos, noside);
10542 if (noside == EVAL_SKIP)
10543 return eval_skip_value (exp);
10544 return ada_value_cast (to_type, val);
10545}
10546
284614f0
JB
10547/* Implement the evaluate_exp routine in the exp_descriptor structure
10548 for the Ada language. */
10549
52ce6436 10550static struct value *
ebf56fd3 10551ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10552 int *pos, enum noside noside)
14f9c5c9
AS
10553{
10554 enum exp_opcode op;
b5385fc0 10555 int tem;
14f9c5c9 10556 int pc;
5ec18f2b 10557 int preeval_pos;
14f9c5c9
AS
10558 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10559 struct type *type;
52ce6436 10560 int nargs, oplen;
d2e4a39e 10561 struct value **argvec;
14f9c5c9 10562
d2e4a39e
AS
10563 pc = *pos;
10564 *pos += 1;
14f9c5c9
AS
10565 op = exp->elts[pc].opcode;
10566
d2e4a39e 10567 switch (op)
14f9c5c9
AS
10568 {
10569 default:
10570 *pos -= 1;
6e48bd2c 10571 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10572
10573 if (noside == EVAL_NORMAL)
10574 arg1 = unwrap_value (arg1);
6e48bd2c 10575
edd079d9 10576 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10577 then we need to perform the conversion manually, because
10578 evaluate_subexp_standard doesn't do it. This conversion is
10579 necessary in Ada because the different kinds of float/fixed
10580 types in Ada have different representations.
10581
10582 Similarly, we need to perform the conversion from OP_LONG
10583 ourselves. */
edd079d9 10584 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10585 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10586
10587 return arg1;
4c4b4cd2
PH
10588
10589 case OP_STRING:
10590 {
76a01679 10591 struct value *result;
5b4ee69b 10592
76a01679
JB
10593 *pos -= 1;
10594 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10595 /* The result type will have code OP_STRING, bashed there from
10596 OP_ARRAY. Bash it back. */
df407dfe
AC
10597 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10598 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10599 return result;
4c4b4cd2 10600 }
14f9c5c9
AS
10601
10602 case UNOP_CAST:
10603 (*pos) += 2;
10604 type = exp->elts[pc + 1].type;
ced9779b 10605 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10606
4c4b4cd2
PH
10607 case UNOP_QUAL:
10608 (*pos) += 2;
10609 type = exp->elts[pc + 1].type;
10610 return ada_evaluate_subexp (type, exp, pos, noside);
10611
14f9c5c9
AS
10612 case BINOP_ASSIGN:
10613 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10614 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10615 {
10616 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10617 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10618 return arg1;
10619 return ada_value_assign (arg1, arg1);
10620 }
003f3813
JB
10621 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10622 except if the lhs of our assignment is a convenience variable.
10623 In the case of assigning to a convenience variable, the lhs
10624 should be exactly the result of the evaluation of the rhs. */
10625 type = value_type (arg1);
10626 if (VALUE_LVAL (arg1) == lval_internalvar)
10627 type = NULL;
10628 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10629 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10630 return arg1;
df407dfe
AC
10631 if (ada_is_fixed_point_type (value_type (arg1)))
10632 arg2 = cast_to_fixed (value_type (arg1), arg2);
10633 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10634 error
323e0a4a 10635 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10636 else
df407dfe 10637 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10638 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10639
10640 case BINOP_ADD:
10641 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10642 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10643 if (noside == EVAL_SKIP)
4c4b4cd2 10644 goto nosideret;
2ac8a782
JB
10645 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10646 return (value_from_longest
10647 (value_type (arg1),
10648 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10649 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10650 return (value_from_longest
10651 (value_type (arg2),
10652 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10653 if ((ada_is_fixed_point_type (value_type (arg1))
10654 || ada_is_fixed_point_type (value_type (arg2)))
10655 && value_type (arg1) != value_type (arg2))
323e0a4a 10656 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10657 /* Do the addition, and cast the result to the type of the first
10658 argument. We cannot cast the result to a reference type, so if
10659 ARG1 is a reference type, find its underlying type. */
10660 type = value_type (arg1);
10661 while (TYPE_CODE (type) == TYPE_CODE_REF)
10662 type = TYPE_TARGET_TYPE (type);
f44316fa 10663 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10664 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10665
10666 case BINOP_SUB:
10667 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10668 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10669 if (noside == EVAL_SKIP)
4c4b4cd2 10670 goto nosideret;
2ac8a782
JB
10671 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10672 return (value_from_longest
10673 (value_type (arg1),
10674 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10675 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10676 return (value_from_longest
10677 (value_type (arg2),
10678 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10679 if ((ada_is_fixed_point_type (value_type (arg1))
10680 || ada_is_fixed_point_type (value_type (arg2)))
10681 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10682 error (_("Operands of fixed-point subtraction "
10683 "must have the same type"));
b7789565
JB
10684 /* Do the substraction, and cast the result to the type of the first
10685 argument. We cannot cast the result to a reference type, so if
10686 ARG1 is a reference type, find its underlying type. */
10687 type = value_type (arg1);
10688 while (TYPE_CODE (type) == TYPE_CODE_REF)
10689 type = TYPE_TARGET_TYPE (type);
f44316fa 10690 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10691 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10692
10693 case BINOP_MUL:
10694 case BINOP_DIV:
e1578042
JB
10695 case BINOP_REM:
10696 case BINOP_MOD:
14f9c5c9
AS
10697 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10698 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10699 if (noside == EVAL_SKIP)
4c4b4cd2 10700 goto nosideret;
e1578042 10701 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10702 {
10703 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10704 return value_zero (value_type (arg1), not_lval);
10705 }
14f9c5c9 10706 else
4c4b4cd2 10707 {
a53b7a21 10708 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10709 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10710 arg1 = cast_from_fixed (type, arg1);
df407dfe 10711 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10712 arg2 = cast_from_fixed (type, arg2);
f44316fa 10713 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10714 return ada_value_binop (arg1, arg2, op);
10715 }
10716
4c4b4cd2
PH
10717 case BINOP_EQUAL:
10718 case BINOP_NOTEQUAL:
14f9c5c9 10719 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10720 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10721 if (noside == EVAL_SKIP)
76a01679 10722 goto nosideret;
4c4b4cd2 10723 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10724 tem = 0;
4c4b4cd2 10725 else
f44316fa
UW
10726 {
10727 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10728 tem = ada_value_equal (arg1, arg2);
10729 }
4c4b4cd2 10730 if (op == BINOP_NOTEQUAL)
76a01679 10731 tem = !tem;
fbb06eb1
UW
10732 type = language_bool_type (exp->language_defn, exp->gdbarch);
10733 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10734
10735 case UNOP_NEG:
10736 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10737 if (noside == EVAL_SKIP)
10738 goto nosideret;
df407dfe
AC
10739 else if (ada_is_fixed_point_type (value_type (arg1)))
10740 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10741 else
f44316fa
UW
10742 {
10743 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10744 return value_neg (arg1);
10745 }
4c4b4cd2 10746
2330c6c6
JB
10747 case BINOP_LOGICAL_AND:
10748 case BINOP_LOGICAL_OR:
10749 case UNOP_LOGICAL_NOT:
000d5124
JB
10750 {
10751 struct value *val;
10752
10753 *pos -= 1;
10754 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10755 type = language_bool_type (exp->language_defn, exp->gdbarch);
10756 return value_cast (type, val);
000d5124 10757 }
2330c6c6
JB
10758
10759 case BINOP_BITWISE_AND:
10760 case BINOP_BITWISE_IOR:
10761 case BINOP_BITWISE_XOR:
000d5124
JB
10762 {
10763 struct value *val;
10764
10765 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10766 *pos = pc;
10767 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10768
10769 return value_cast (value_type (arg1), val);
10770 }
2330c6c6 10771
14f9c5c9
AS
10772 case OP_VAR_VALUE:
10773 *pos -= 1;
6799def4 10774
14f9c5c9 10775 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10776 {
10777 *pos += 4;
10778 goto nosideret;
10779 }
da5c522f
JB
10780
10781 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10782 /* Only encountered when an unresolved symbol occurs in a
10783 context other than a function call, in which case, it is
52ce6436 10784 invalid. */
323e0a4a 10785 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10786 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10787
10788 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10789 {
0c1f74cf 10790 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10791 /* Check to see if this is a tagged type. We also need to handle
10792 the case where the type is a reference to a tagged type, but
10793 we have to be careful to exclude pointers to tagged types.
10794 The latter should be shown as usual (as a pointer), whereas
10795 a reference should mostly be transparent to the user. */
10796 if (ada_is_tagged_type (type, 0)
023db19c 10797 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10798 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10799 {
10800 /* Tagged types are a little special in the fact that the real
10801 type is dynamic and can only be determined by inspecting the
10802 object's tag. This means that we need to get the object's
10803 value first (EVAL_NORMAL) and then extract the actual object
10804 type from its tag.
10805
10806 Note that we cannot skip the final step where we extract
10807 the object type from its tag, because the EVAL_NORMAL phase
10808 results in dynamic components being resolved into fixed ones.
10809 This can cause problems when trying to print the type
10810 description of tagged types whose parent has a dynamic size:
10811 We use the type name of the "_parent" component in order
10812 to print the name of the ancestor type in the type description.
10813 If that component had a dynamic size, the resolution into
10814 a fixed type would result in the loss of that type name,
10815 thus preventing us from printing the name of the ancestor
10816 type in the type description. */
10817 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10818
10819 if (TYPE_CODE (type) != TYPE_CODE_REF)
10820 {
10821 struct type *actual_type;
10822
10823 actual_type = type_from_tag (ada_value_tag (arg1));
10824 if (actual_type == NULL)
10825 /* If, for some reason, we were unable to determine
10826 the actual type from the tag, then use the static
10827 approximation that we just computed as a fallback.
10828 This can happen if the debugging information is
10829 incomplete, for instance. */
10830 actual_type = type;
10831 return value_zero (actual_type, not_lval);
10832 }
10833 else
10834 {
10835 /* In the case of a ref, ada_coerce_ref takes care
10836 of determining the actual type. But the evaluation
10837 should return a ref as it should be valid to ask
10838 for its address; so rebuild a ref after coerce. */
10839 arg1 = ada_coerce_ref (arg1);
a65cfae5 10840 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10841 }
10842 }
0c1f74cf 10843
84754697
JB
10844 /* Records and unions for which GNAT encodings have been
10845 generated need to be statically fixed as well.
10846 Otherwise, non-static fixing produces a type where
10847 all dynamic properties are removed, which prevents "ptype"
10848 from being able to completely describe the type.
10849 For instance, a case statement in a variant record would be
10850 replaced by the relevant components based on the actual
10851 value of the discriminants. */
10852 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10853 && dynamic_template_type (type) != NULL)
10854 || (TYPE_CODE (type) == TYPE_CODE_UNION
10855 && ada_find_parallel_type (type, "___XVU") != NULL))
10856 {
10857 *pos += 4;
10858 return value_zero (to_static_fixed_type (type), not_lval);
10859 }
4c4b4cd2 10860 }
da5c522f
JB
10861
10862 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10863 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10864
10865 case OP_FUNCALL:
10866 (*pos) += 2;
10867
10868 /* Allocate arg vector, including space for the function to be
10869 called in argvec[0] and a terminating NULL. */
10870 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10871 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10872
10873 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10874 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10875 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10876 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10877 else
10878 {
10879 for (tem = 0; tem <= nargs; tem += 1)
10880 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10881 argvec[tem] = 0;
10882
10883 if (noside == EVAL_SKIP)
10884 goto nosideret;
10885 }
10886
ad82864c
JB
10887 if (ada_is_constrained_packed_array_type
10888 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10889 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10890 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10891 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10892 /* This is a packed array that has already been fixed, and
10893 therefore already coerced to a simple array. Nothing further
10894 to do. */
10895 ;
e6c2c623
PMR
10896 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10897 {
10898 /* Make sure we dereference references so that all the code below
10899 feels like it's really handling the referenced value. Wrapping
10900 types (for alignment) may be there, so make sure we strip them as
10901 well. */
10902 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10903 }
10904 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10905 && VALUE_LVAL (argvec[0]) == lval_memory)
10906 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10907
df407dfe 10908 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10909
10910 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10911 them. So, if this is an array typedef (encoding use for array
10912 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10913 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10914 type = ada_typedef_target_type (type);
10915
4c4b4cd2
PH
10916 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10917 {
61ee279c 10918 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10919 {
10920 case TYPE_CODE_FUNC:
61ee279c 10921 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10922 break;
10923 case TYPE_CODE_ARRAY:
10924 break;
10925 case TYPE_CODE_STRUCT:
10926 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10927 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10928 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10929 break;
10930 default:
323e0a4a 10931 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10932 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10933 break;
10934 }
10935 }
10936
10937 switch (TYPE_CODE (type))
10938 {
10939 case TYPE_CODE_FUNC:
10940 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10941 {
7022349d
PA
10942 if (TYPE_TARGET_TYPE (type) == NULL)
10943 error_call_unknown_return_type (NULL);
10944 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10945 }
7022349d 10946 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
c8ea1972
PH
10947 case TYPE_CODE_INTERNAL_FUNCTION:
10948 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10949 /* We don't know anything about what the internal
10950 function might return, but we have to return
10951 something. */
10952 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10953 not_lval);
10954 else
10955 return call_internal_function (exp->gdbarch, exp->language_defn,
10956 argvec[0], nargs, argvec + 1);
10957
4c4b4cd2
PH
10958 case TYPE_CODE_STRUCT:
10959 {
10960 int arity;
10961
4c4b4cd2
PH
10962 arity = ada_array_arity (type);
10963 type = ada_array_element_type (type, nargs);
10964 if (type == NULL)
323e0a4a 10965 error (_("cannot subscript or call a record"));
4c4b4cd2 10966 if (arity != nargs)
323e0a4a 10967 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10968 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10969 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10970 return
10971 unwrap_value (ada_value_subscript
10972 (argvec[0], nargs, argvec + 1));
10973 }
10974 case TYPE_CODE_ARRAY:
10975 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10976 {
10977 type = ada_array_element_type (type, nargs);
10978 if (type == NULL)
323e0a4a 10979 error (_("element type of array unknown"));
4c4b4cd2 10980 else
0a07e705 10981 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10982 }
10983 return
10984 unwrap_value (ada_value_subscript
10985 (ada_coerce_to_simple_array (argvec[0]),
10986 nargs, argvec + 1));
10987 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10988 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10989 {
deede10c 10990 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10991 type = ada_array_element_type (type, nargs);
10992 if (type == NULL)
323e0a4a 10993 error (_("element type of array unknown"));
4c4b4cd2 10994 else
0a07e705 10995 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10996 }
10997 return
deede10c
JB
10998 unwrap_value (ada_value_ptr_subscript (argvec[0],
10999 nargs, argvec + 1));
4c4b4cd2
PH
11000
11001 default:
e1d5a0d2
PH
11002 error (_("Attempt to index or call something other than an "
11003 "array or function"));
4c4b4cd2
PH
11004 }
11005
11006 case TERNOP_SLICE:
11007 {
11008 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11009 struct value *low_bound_val =
11010 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
11011 struct value *high_bound_val =
11012 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11013 LONGEST low_bound;
11014 LONGEST high_bound;
5b4ee69b 11015
994b9211
AC
11016 low_bound_val = coerce_ref (low_bound_val);
11017 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
11018 low_bound = value_as_long (low_bound_val);
11019 high_bound = value_as_long (high_bound_val);
963a6417 11020
4c4b4cd2
PH
11021 if (noside == EVAL_SKIP)
11022 goto nosideret;
11023
4c4b4cd2
PH
11024 /* If this is a reference to an aligner type, then remove all
11025 the aligners. */
df407dfe
AC
11026 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11027 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11028 TYPE_TARGET_TYPE (value_type (array)) =
11029 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 11030
ad82864c 11031 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 11032 error (_("cannot slice a packed array"));
4c4b4cd2
PH
11033
11034 /* If this is a reference to an array or an array lvalue,
11035 convert to a pointer. */
df407dfe
AC
11036 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11037 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
11038 && VALUE_LVAL (array) == lval_memory))
11039 array = value_addr (array);
11040
1265e4aa 11041 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 11042 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 11043 (value_type (array))))
0b5d8877 11044 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
11045
11046 array = ada_coerce_to_simple_array_ptr (array);
11047
714e53ab
PH
11048 /* If we have more than one level of pointer indirection,
11049 dereference the value until we get only one level. */
df407dfe
AC
11050 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11051 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
11052 == TYPE_CODE_PTR))
11053 array = value_ind (array);
11054
11055 /* Make sure we really do have an array type before going further,
11056 to avoid a SEGV when trying to get the index type or the target
11057 type later down the road if the debug info generated by
11058 the compiler is incorrect or incomplete. */
df407dfe 11059 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 11060 error (_("cannot take slice of non-array"));
714e53ab 11061
828292f2
JB
11062 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11063 == TYPE_CODE_PTR)
4c4b4cd2 11064 {
828292f2
JB
11065 struct type *type0 = ada_check_typedef (value_type (array));
11066
0b5d8877 11067 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 11068 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
11069 else
11070 {
11071 struct type *arr_type0 =
828292f2 11072 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 11073
f5938064
JG
11074 return ada_value_slice_from_ptr (array, arr_type0,
11075 longest_to_int (low_bound),
11076 longest_to_int (high_bound));
4c4b4cd2
PH
11077 }
11078 }
11079 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11080 return array;
11081 else if (high_bound < low_bound)
df407dfe 11082 return empty_array (value_type (array), low_bound);
4c4b4cd2 11083 else
529cad9c
PH
11084 return ada_value_slice (array, longest_to_int (low_bound),
11085 longest_to_int (high_bound));
4c4b4cd2 11086 }
14f9c5c9 11087
4c4b4cd2
PH
11088 case UNOP_IN_RANGE:
11089 (*pos) += 2;
11090 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 11091 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 11092
14f9c5c9 11093 if (noside == EVAL_SKIP)
4c4b4cd2 11094 goto nosideret;
14f9c5c9 11095
4c4b4cd2
PH
11096 switch (TYPE_CODE (type))
11097 {
11098 default:
e1d5a0d2
PH
11099 lim_warning (_("Membership test incompletely implemented; "
11100 "always returns true"));
fbb06eb1
UW
11101 type = language_bool_type (exp->language_defn, exp->gdbarch);
11102 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
11103
11104 case TYPE_CODE_RANGE:
030b4912
UW
11105 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11106 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
11107 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11108 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
11109 type = language_bool_type (exp->language_defn, exp->gdbarch);
11110 return
11111 value_from_longest (type,
4c4b4cd2
PH
11112 (value_less (arg1, arg3)
11113 || value_equal (arg1, arg3))
11114 && (value_less (arg2, arg1)
11115 || value_equal (arg2, arg1)));
11116 }
11117
11118 case BINOP_IN_BOUNDS:
14f9c5c9 11119 (*pos) += 2;
4c4b4cd2
PH
11120 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11121 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11122
4c4b4cd2
PH
11123 if (noside == EVAL_SKIP)
11124 goto nosideret;
14f9c5c9 11125
4c4b4cd2 11126 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
11127 {
11128 type = language_bool_type (exp->language_defn, exp->gdbarch);
11129 return value_zero (type, not_lval);
11130 }
14f9c5c9 11131
4c4b4cd2 11132 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11133
1eea4ebd
UW
11134 type = ada_index_type (value_type (arg2), tem, "range");
11135 if (!type)
11136 type = value_type (arg1);
14f9c5c9 11137
1eea4ebd
UW
11138 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11139 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11140
f44316fa
UW
11141 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11142 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11143 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11144 return
fbb06eb1 11145 value_from_longest (type,
4c4b4cd2
PH
11146 (value_less (arg1, arg3)
11147 || value_equal (arg1, arg3))
11148 && (value_less (arg2, arg1)
11149 || value_equal (arg2, arg1)));
11150
11151 case TERNOP_IN_RANGE:
11152 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11153 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11154 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11155
11156 if (noside == EVAL_SKIP)
11157 goto nosideret;
11158
f44316fa
UW
11159 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11160 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11161 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11162 return
fbb06eb1 11163 value_from_longest (type,
4c4b4cd2
PH
11164 (value_less (arg1, arg3)
11165 || value_equal (arg1, arg3))
11166 && (value_less (arg2, arg1)
11167 || value_equal (arg2, arg1)));
11168
11169 case OP_ATR_FIRST:
11170 case OP_ATR_LAST:
11171 case OP_ATR_LENGTH:
11172 {
76a01679 11173 struct type *type_arg;
5b4ee69b 11174
76a01679
JB
11175 if (exp->elts[*pos].opcode == OP_TYPE)
11176 {
11177 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11178 arg1 = NULL;
5bc23cb3 11179 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11180 }
11181 else
11182 {
11183 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11184 type_arg = NULL;
11185 }
11186
11187 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11188 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11189 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11190 *pos += 4;
11191
11192 if (noside == EVAL_SKIP)
11193 goto nosideret;
11194
11195 if (type_arg == NULL)
11196 {
11197 arg1 = ada_coerce_ref (arg1);
11198
ad82864c 11199 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11200 arg1 = ada_coerce_to_simple_array (arg1);
11201
aa4fb036 11202 if (op == OP_ATR_LENGTH)
1eea4ebd 11203 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11204 else
11205 {
11206 type = ada_index_type (value_type (arg1), tem,
11207 ada_attribute_name (op));
11208 if (type == NULL)
11209 type = builtin_type (exp->gdbarch)->builtin_int;
11210 }
76a01679
JB
11211
11212 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11213 return allocate_value (type);
76a01679
JB
11214
11215 switch (op)
11216 {
11217 default: /* Should never happen. */
323e0a4a 11218 error (_("unexpected attribute encountered"));
76a01679 11219 case OP_ATR_FIRST:
1eea4ebd
UW
11220 return value_from_longest
11221 (type, ada_array_bound (arg1, tem, 0));
76a01679 11222 case OP_ATR_LAST:
1eea4ebd
UW
11223 return value_from_longest
11224 (type, ada_array_bound (arg1, tem, 1));
76a01679 11225 case OP_ATR_LENGTH:
1eea4ebd
UW
11226 return value_from_longest
11227 (type, ada_array_length (arg1, tem));
76a01679
JB
11228 }
11229 }
11230 else if (discrete_type_p (type_arg))
11231 {
11232 struct type *range_type;
0d5cff50 11233 const char *name = ada_type_name (type_arg);
5b4ee69b 11234
76a01679
JB
11235 range_type = NULL;
11236 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11237 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11238 if (range_type == NULL)
11239 range_type = type_arg;
11240 switch (op)
11241 {
11242 default:
323e0a4a 11243 error (_("unexpected attribute encountered"));
76a01679 11244 case OP_ATR_FIRST:
690cc4eb 11245 return value_from_longest
43bbcdc2 11246 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11247 case OP_ATR_LAST:
690cc4eb 11248 return value_from_longest
43bbcdc2 11249 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11250 case OP_ATR_LENGTH:
323e0a4a 11251 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11252 }
11253 }
11254 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11255 error (_("unimplemented type attribute"));
76a01679
JB
11256 else
11257 {
11258 LONGEST low, high;
11259
ad82864c
JB
11260 if (ada_is_constrained_packed_array_type (type_arg))
11261 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11262
aa4fb036 11263 if (op == OP_ATR_LENGTH)
1eea4ebd 11264 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11265 else
11266 {
11267 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11268 if (type == NULL)
11269 type = builtin_type (exp->gdbarch)->builtin_int;
11270 }
1eea4ebd 11271
76a01679
JB
11272 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11273 return allocate_value (type);
11274
11275 switch (op)
11276 {
11277 default:
323e0a4a 11278 error (_("unexpected attribute encountered"));
76a01679 11279 case OP_ATR_FIRST:
1eea4ebd 11280 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11281 return value_from_longest (type, low);
11282 case OP_ATR_LAST:
1eea4ebd 11283 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11284 return value_from_longest (type, high);
11285 case OP_ATR_LENGTH:
1eea4ebd
UW
11286 low = ada_array_bound_from_type (type_arg, tem, 0);
11287 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11288 return value_from_longest (type, high - low + 1);
11289 }
11290 }
14f9c5c9
AS
11291 }
11292
4c4b4cd2
PH
11293 case OP_ATR_TAG:
11294 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11295 if (noside == EVAL_SKIP)
76a01679 11296 goto nosideret;
4c4b4cd2
PH
11297
11298 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11299 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11300
11301 return ada_value_tag (arg1);
11302
11303 case OP_ATR_MIN:
11304 case OP_ATR_MAX:
11305 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11306 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11307 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11308 if (noside == EVAL_SKIP)
76a01679 11309 goto nosideret;
d2e4a39e 11310 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11311 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11312 else
f44316fa
UW
11313 {
11314 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11315 return value_binop (arg1, arg2,
11316 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11317 }
14f9c5c9 11318
4c4b4cd2
PH
11319 case OP_ATR_MODULUS:
11320 {
31dedfee 11321 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11322
5b4ee69b 11323 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11324 if (noside == EVAL_SKIP)
11325 goto nosideret;
4c4b4cd2 11326
76a01679 11327 if (!ada_is_modular_type (type_arg))
323e0a4a 11328 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11329
76a01679
JB
11330 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11331 ada_modulus (type_arg));
4c4b4cd2
PH
11332 }
11333
11334
11335 case OP_ATR_POS:
11336 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11337 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11338 if (noside == EVAL_SKIP)
76a01679 11339 goto nosideret;
3cb382c9
UW
11340 type = builtin_type (exp->gdbarch)->builtin_int;
11341 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11342 return value_zero (type, not_lval);
14f9c5c9 11343 else
3cb382c9 11344 return value_pos_atr (type, arg1);
14f9c5c9 11345
4c4b4cd2
PH
11346 case OP_ATR_SIZE:
11347 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11348 type = value_type (arg1);
11349
11350 /* If the argument is a reference, then dereference its type, since
11351 the user is really asking for the size of the actual object,
11352 not the size of the pointer. */
11353 if (TYPE_CODE (type) == TYPE_CODE_REF)
11354 type = TYPE_TARGET_TYPE (type);
11355
4c4b4cd2 11356 if (noside == EVAL_SKIP)
76a01679 11357 goto nosideret;
4c4b4cd2 11358 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11359 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11360 else
22601c15 11361 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11362 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11363
11364 case OP_ATR_VAL:
11365 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11366 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11367 type = exp->elts[pc + 2].type;
14f9c5c9 11368 if (noside == EVAL_SKIP)
76a01679 11369 goto nosideret;
4c4b4cd2 11370 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11371 return value_zero (type, not_lval);
4c4b4cd2 11372 else
76a01679 11373 return value_val_atr (type, arg1);
4c4b4cd2
PH
11374
11375 case BINOP_EXP:
11376 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11377 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11378 if (noside == EVAL_SKIP)
11379 goto nosideret;
11380 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11381 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11382 else
f44316fa
UW
11383 {
11384 /* For integer exponentiation operations,
11385 only promote the first argument. */
11386 if (is_integral_type (value_type (arg2)))
11387 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11388 else
11389 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11390
11391 return value_binop (arg1, arg2, op);
11392 }
4c4b4cd2
PH
11393
11394 case UNOP_PLUS:
11395 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11396 if (noside == EVAL_SKIP)
11397 goto nosideret;
11398 else
11399 return arg1;
11400
11401 case UNOP_ABS:
11402 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11403 if (noside == EVAL_SKIP)
11404 goto nosideret;
f44316fa 11405 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11406 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11407 return value_neg (arg1);
14f9c5c9 11408 else
4c4b4cd2 11409 return arg1;
14f9c5c9
AS
11410
11411 case UNOP_IND:
5ec18f2b 11412 preeval_pos = *pos;
6b0d7253 11413 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11414 if (noside == EVAL_SKIP)
4c4b4cd2 11415 goto nosideret;
df407dfe 11416 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11417 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11418 {
11419 if (ada_is_array_descriptor_type (type))
11420 /* GDB allows dereferencing GNAT array descriptors. */
11421 {
11422 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11423
4c4b4cd2 11424 if (arrType == NULL)
323e0a4a 11425 error (_("Attempt to dereference null array pointer."));
00a4c844 11426 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11427 }
11428 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11429 || TYPE_CODE (type) == TYPE_CODE_REF
11430 /* In C you can dereference an array to get the 1st elt. */
11431 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11432 {
5ec18f2b
JG
11433 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11434 only be determined by inspecting the object's tag.
11435 This means that we need to evaluate completely the
11436 expression in order to get its type. */
11437
023db19c
JB
11438 if ((TYPE_CODE (type) == TYPE_CODE_REF
11439 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11440 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11441 {
11442 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11443 EVAL_NORMAL);
11444 type = value_type (ada_value_ind (arg1));
11445 }
11446 else
11447 {
11448 type = to_static_fixed_type
11449 (ada_aligned_type
11450 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11451 }
c1b5a1a6 11452 ada_ensure_varsize_limit (type);
714e53ab
PH
11453 return value_zero (type, lval_memory);
11454 }
4c4b4cd2 11455 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11456 {
11457 /* GDB allows dereferencing an int. */
11458 if (expect_type == NULL)
11459 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11460 lval_memory);
11461 else
11462 {
11463 expect_type =
11464 to_static_fixed_type (ada_aligned_type (expect_type));
11465 return value_zero (expect_type, lval_memory);
11466 }
11467 }
4c4b4cd2 11468 else
323e0a4a 11469 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11470 }
0963b4bd 11471 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11472 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11473
96967637
JB
11474 if (TYPE_CODE (type) == TYPE_CODE_INT)
11475 /* GDB allows dereferencing an int. If we were given
11476 the expect_type, then use that as the target type.
11477 Otherwise, assume that the target type is an int. */
11478 {
11479 if (expect_type != NULL)
11480 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11481 arg1));
11482 else
11483 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11484 (CORE_ADDR) value_as_address (arg1));
11485 }
6b0d7253 11486
4c4b4cd2
PH
11487 if (ada_is_array_descriptor_type (type))
11488 /* GDB allows dereferencing GNAT array descriptors. */
11489 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11490 else
4c4b4cd2 11491 return ada_value_ind (arg1);
14f9c5c9
AS
11492
11493 case STRUCTOP_STRUCT:
11494 tem = longest_to_int (exp->elts[pc + 1].longconst);
11495 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11496 preeval_pos = *pos;
14f9c5c9
AS
11497 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11498 if (noside == EVAL_SKIP)
4c4b4cd2 11499 goto nosideret;
14f9c5c9 11500 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11501 {
df407dfe 11502 struct type *type1 = value_type (arg1);
5b4ee69b 11503
76a01679
JB
11504 if (ada_is_tagged_type (type1, 1))
11505 {
11506 type = ada_lookup_struct_elt_type (type1,
11507 &exp->elts[pc + 2].string,
988f6b3d 11508 1, 1);
5ec18f2b
JG
11509
11510 /* If the field is not found, check if it exists in the
11511 extension of this object's type. This means that we
11512 need to evaluate completely the expression. */
11513
76a01679 11514 if (type == NULL)
5ec18f2b
JG
11515 {
11516 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11517 EVAL_NORMAL);
11518 arg1 = ada_value_struct_elt (arg1,
11519 &exp->elts[pc + 2].string,
11520 0);
11521 arg1 = unwrap_value (arg1);
11522 type = value_type (ada_to_fixed_value (arg1));
11523 }
76a01679
JB
11524 }
11525 else
11526 type =
11527 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11528 0);
76a01679
JB
11529
11530 return value_zero (ada_aligned_type (type), lval_memory);
11531 }
14f9c5c9 11532 else
a579cd9a
MW
11533 {
11534 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11535 arg1 = unwrap_value (arg1);
11536 return ada_to_fixed_value (arg1);
11537 }
284614f0 11538
14f9c5c9 11539 case OP_TYPE:
4c4b4cd2
PH
11540 /* The value is not supposed to be used. This is here to make it
11541 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11542 (*pos) += 2;
11543 if (noside == EVAL_SKIP)
4c4b4cd2 11544 goto nosideret;
14f9c5c9 11545 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11546 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11547 else
323e0a4a 11548 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11549
11550 case OP_AGGREGATE:
11551 case OP_CHOICES:
11552 case OP_OTHERS:
11553 case OP_DISCRETE_RANGE:
11554 case OP_POSITIONAL:
11555 case OP_NAME:
11556 if (noside == EVAL_NORMAL)
11557 switch (op)
11558 {
11559 case OP_NAME:
11560 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11561 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11562 case OP_AGGREGATE:
11563 error (_("Aggregates only allowed on the right of an assignment"));
11564 default:
0963b4bd
MS
11565 internal_error (__FILE__, __LINE__,
11566 _("aggregate apparently mangled"));
52ce6436
PH
11567 }
11568
11569 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11570 *pos += oplen - 1;
11571 for (tem = 0; tem < nargs; tem += 1)
11572 ada_evaluate_subexp (NULL, exp, pos, noside);
11573 goto nosideret;
14f9c5c9
AS
11574 }
11575
11576nosideret:
ced9779b 11577 return eval_skip_value (exp);
14f9c5c9 11578}
14f9c5c9 11579\f
d2e4a39e 11580
4c4b4cd2 11581 /* Fixed point */
14f9c5c9
AS
11582
11583/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11584 type name that encodes the 'small and 'delta information.
4c4b4cd2 11585 Otherwise, return NULL. */
14f9c5c9 11586
d2e4a39e 11587static const char *
ebf56fd3 11588fixed_type_info (struct type *type)
14f9c5c9 11589{
d2e4a39e 11590 const char *name = ada_type_name (type);
14f9c5c9
AS
11591 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11592
d2e4a39e
AS
11593 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11594 {
14f9c5c9 11595 const char *tail = strstr (name, "___XF_");
5b4ee69b 11596
14f9c5c9 11597 if (tail == NULL)
4c4b4cd2 11598 return NULL;
d2e4a39e 11599 else
4c4b4cd2 11600 return tail + 5;
14f9c5c9
AS
11601 }
11602 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11603 return fixed_type_info (TYPE_TARGET_TYPE (type));
11604 else
11605 return NULL;
11606}
11607
4c4b4cd2 11608/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11609
11610int
ebf56fd3 11611ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11612{
11613 return fixed_type_info (type) != NULL;
11614}
11615
4c4b4cd2
PH
11616/* Return non-zero iff TYPE represents a System.Address type. */
11617
11618int
11619ada_is_system_address_type (struct type *type)
11620{
11621 return (TYPE_NAME (type)
11622 && strcmp (TYPE_NAME (type), "system__address") == 0);
11623}
11624
14f9c5c9 11625/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11626 type, return the target floating-point type to be used to represent
11627 of this type during internal computation. */
11628
11629static struct type *
11630ada_scaling_type (struct type *type)
11631{
11632 return builtin_type (get_type_arch (type))->builtin_long_double;
11633}
11634
11635/* Assuming that TYPE is the representation of an Ada fixed-point
11636 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11637 delta cannot be determined. */
14f9c5c9 11638
50eff16b 11639struct value *
ebf56fd3 11640ada_delta (struct type *type)
14f9c5c9
AS
11641{
11642 const char *encoding = fixed_type_info (type);
50eff16b
UW
11643 struct type *scale_type = ada_scaling_type (type);
11644
11645 long long num, den;
11646
11647 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11648 return nullptr;
d2e4a39e 11649 else
50eff16b
UW
11650 return value_binop (value_from_longest (scale_type, num),
11651 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11652}
11653
11654/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11655 factor ('SMALL value) associated with the type. */
14f9c5c9 11656
50eff16b
UW
11657struct value *
11658ada_scaling_factor (struct type *type)
14f9c5c9
AS
11659{
11660 const char *encoding = fixed_type_info (type);
50eff16b
UW
11661 struct type *scale_type = ada_scaling_type (type);
11662
11663 long long num0, den0, num1, den1;
14f9c5c9 11664 int n;
d2e4a39e 11665
50eff16b 11666 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11667 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11668
11669 if (n < 2)
50eff16b 11670 return value_from_longest (scale_type, 1);
14f9c5c9 11671 else if (n == 4)
50eff16b
UW
11672 return value_binop (value_from_longest (scale_type, num1),
11673 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11674 else
50eff16b
UW
11675 return value_binop (value_from_longest (scale_type, num0),
11676 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11677}
11678
14f9c5c9 11679\f
d2e4a39e 11680
4c4b4cd2 11681 /* Range types */
14f9c5c9
AS
11682
11683/* Scan STR beginning at position K for a discriminant name, and
11684 return the value of that discriminant field of DVAL in *PX. If
11685 PNEW_K is not null, put the position of the character beyond the
11686 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11687 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11688
11689static int
108d56a4 11690scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11691 int *pnew_k)
14f9c5c9
AS
11692{
11693 static char *bound_buffer = NULL;
11694 static size_t bound_buffer_len = 0;
5da1a4d3 11695 const char *pstart, *pend, *bound;
d2e4a39e 11696 struct value *bound_val;
14f9c5c9
AS
11697
11698 if (dval == NULL || str == NULL || str[k] == '\0')
11699 return 0;
11700
5da1a4d3
SM
11701 pstart = str + k;
11702 pend = strstr (pstart, "__");
14f9c5c9
AS
11703 if (pend == NULL)
11704 {
5da1a4d3 11705 bound = pstart;
14f9c5c9
AS
11706 k += strlen (bound);
11707 }
d2e4a39e 11708 else
14f9c5c9 11709 {
5da1a4d3
SM
11710 int len = pend - pstart;
11711
11712 /* Strip __ and beyond. */
11713 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11714 strncpy (bound_buffer, pstart, len);
11715 bound_buffer[len] = '\0';
11716
14f9c5c9 11717 bound = bound_buffer;
d2e4a39e 11718 k = pend - str;
14f9c5c9 11719 }
d2e4a39e 11720
df407dfe 11721 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11722 if (bound_val == NULL)
11723 return 0;
11724
11725 *px = value_as_long (bound_val);
11726 if (pnew_k != NULL)
11727 *pnew_k = k;
11728 return 1;
11729}
11730
11731/* Value of variable named NAME in the current environment. If
11732 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11733 otherwise causes an error with message ERR_MSG. */
11734
d2e4a39e 11735static struct value *
edb0c9cb 11736get_var_value (const char *name, const char *err_msg)
14f9c5c9 11737{
b5ec771e 11738 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11739
54d343a2 11740 std::vector<struct block_symbol> syms;
b5ec771e
PA
11741 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11742 get_selected_block (0),
11743 VAR_DOMAIN, &syms, 1);
14f9c5c9
AS
11744
11745 if (nsyms != 1)
11746 {
11747 if (err_msg == NULL)
4c4b4cd2 11748 return 0;
14f9c5c9 11749 else
8a3fe4f8 11750 error (("%s"), err_msg);
14f9c5c9
AS
11751 }
11752
54d343a2 11753 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11754}
d2e4a39e 11755
edb0c9cb
PA
11756/* Value of integer variable named NAME in the current environment.
11757 If no such variable is found, returns false. Otherwise, sets VALUE
11758 to the variable's value and returns true. */
4c4b4cd2 11759
edb0c9cb
PA
11760bool
11761get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11762{
4c4b4cd2 11763 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11764
14f9c5c9 11765 if (var_val == 0)
edb0c9cb
PA
11766 return false;
11767
11768 value = value_as_long (var_val);
11769 return true;
14f9c5c9 11770}
d2e4a39e 11771
14f9c5c9
AS
11772
11773/* Return a range type whose base type is that of the range type named
11774 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11775 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11776 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11777 corresponding range type from debug information; fall back to using it
11778 if symbol lookup fails. If a new type must be created, allocate it
11779 like ORIG_TYPE was. The bounds information, in general, is encoded
11780 in NAME, the base type given in the named range type. */
14f9c5c9 11781
d2e4a39e 11782static struct type *
28c85d6c 11783to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11784{
0d5cff50 11785 const char *name;
14f9c5c9 11786 struct type *base_type;
108d56a4 11787 const char *subtype_info;
14f9c5c9 11788
28c85d6c
JB
11789 gdb_assert (raw_type != NULL);
11790 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11791
1ce677a4 11792 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11793 base_type = TYPE_TARGET_TYPE (raw_type);
11794 else
11795 base_type = raw_type;
11796
28c85d6c 11797 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11798 subtype_info = strstr (name, "___XD");
11799 if (subtype_info == NULL)
690cc4eb 11800 {
43bbcdc2
PH
11801 LONGEST L = ada_discrete_type_low_bound (raw_type);
11802 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11803
690cc4eb
PH
11804 if (L < INT_MIN || U > INT_MAX)
11805 return raw_type;
11806 else
0c9c3474
SA
11807 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11808 L, U);
690cc4eb 11809 }
14f9c5c9
AS
11810 else
11811 {
11812 static char *name_buf = NULL;
11813 static size_t name_len = 0;
11814 int prefix_len = subtype_info - name;
11815 LONGEST L, U;
11816 struct type *type;
108d56a4 11817 const char *bounds_str;
14f9c5c9
AS
11818 int n;
11819
11820 GROW_VECT (name_buf, name_len, prefix_len + 5);
11821 strncpy (name_buf, name, prefix_len);
11822 name_buf[prefix_len] = '\0';
11823
11824 subtype_info += 5;
11825 bounds_str = strchr (subtype_info, '_');
11826 n = 1;
11827
d2e4a39e 11828 if (*subtype_info == 'L')
4c4b4cd2
PH
11829 {
11830 if (!ada_scan_number (bounds_str, n, &L, &n)
11831 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11832 return raw_type;
11833 if (bounds_str[n] == '_')
11834 n += 2;
0963b4bd 11835 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11836 n += 1;
11837 subtype_info += 1;
11838 }
d2e4a39e 11839 else
4c4b4cd2 11840 {
4c4b4cd2 11841 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11842 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11843 {
323e0a4a 11844 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11845 L = 1;
11846 }
11847 }
14f9c5c9 11848
d2e4a39e 11849 if (*subtype_info == 'U')
4c4b4cd2
PH
11850 {
11851 if (!ada_scan_number (bounds_str, n, &U, &n)
11852 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11853 return raw_type;
11854 }
d2e4a39e 11855 else
4c4b4cd2 11856 {
4c4b4cd2 11857 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11858 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11859 {
323e0a4a 11860 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11861 U = L;
11862 }
11863 }
14f9c5c9 11864
0c9c3474
SA
11865 type = create_static_range_type (alloc_type_copy (raw_type),
11866 base_type, L, U);
f5a91472
JB
11867 /* create_static_range_type alters the resulting type's length
11868 to match the size of the base_type, which is not what we want.
11869 Set it back to the original range type's length. */
11870 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11871 TYPE_NAME (type) = name;
14f9c5c9
AS
11872 return type;
11873 }
11874}
11875
4c4b4cd2
PH
11876/* True iff NAME is the name of a range type. */
11877
14f9c5c9 11878int
d2e4a39e 11879ada_is_range_type_name (const char *name)
14f9c5c9
AS
11880{
11881 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11882}
14f9c5c9 11883\f
d2e4a39e 11884
4c4b4cd2
PH
11885 /* Modular types */
11886
11887/* True iff TYPE is an Ada modular type. */
14f9c5c9 11888
14f9c5c9 11889int
d2e4a39e 11890ada_is_modular_type (struct type *type)
14f9c5c9 11891{
18af8284 11892 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11893
11894 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11895 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11896 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11897}
11898
4c4b4cd2
PH
11899/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11900
61ee279c 11901ULONGEST
0056e4d5 11902ada_modulus (struct type *type)
14f9c5c9 11903{
43bbcdc2 11904 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11905}
d2e4a39e 11906\f
f7f9143b
JB
11907
11908/* Ada exception catchpoint support:
11909 ---------------------------------
11910
11911 We support 3 kinds of exception catchpoints:
11912 . catchpoints on Ada exceptions
11913 . catchpoints on unhandled Ada exceptions
11914 . catchpoints on failed assertions
11915
11916 Exceptions raised during failed assertions, or unhandled exceptions
11917 could perfectly be caught with the general catchpoint on Ada exceptions.
11918 However, we can easily differentiate these two special cases, and having
11919 the option to distinguish these two cases from the rest can be useful
11920 to zero-in on certain situations.
11921
11922 Exception catchpoints are a specialized form of breakpoint,
11923 since they rely on inserting breakpoints inside known routines
11924 of the GNAT runtime. The implementation therefore uses a standard
11925 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11926 of breakpoint_ops.
11927
0259addd
JB
11928 Support in the runtime for exception catchpoints have been changed
11929 a few times already, and these changes affect the implementation
11930 of these catchpoints. In order to be able to support several
11931 variants of the runtime, we use a sniffer that will determine
28010a5d 11932 the runtime variant used by the program being debugged. */
f7f9143b 11933
82eacd52
JB
11934/* Ada's standard exceptions.
11935
11936 The Ada 83 standard also defined Numeric_Error. But there so many
11937 situations where it was unclear from the Ada 83 Reference Manual
11938 (RM) whether Constraint_Error or Numeric_Error should be raised,
11939 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11940 Interpretation saying that anytime the RM says that Numeric_Error
11941 should be raised, the implementation may raise Constraint_Error.
11942 Ada 95 went one step further and pretty much removed Numeric_Error
11943 from the list of standard exceptions (it made it a renaming of
11944 Constraint_Error, to help preserve compatibility when compiling
11945 an Ada83 compiler). As such, we do not include Numeric_Error from
11946 this list of standard exceptions. */
3d0b0fa3 11947
a121b7c1 11948static const char *standard_exc[] = {
3d0b0fa3
JB
11949 "constraint_error",
11950 "program_error",
11951 "storage_error",
11952 "tasking_error"
11953};
11954
0259addd
JB
11955typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11956
11957/* A structure that describes how to support exception catchpoints
11958 for a given executable. */
11959
11960struct exception_support_info
11961{
11962 /* The name of the symbol to break on in order to insert
11963 a catchpoint on exceptions. */
11964 const char *catch_exception_sym;
11965
11966 /* The name of the symbol to break on in order to insert
11967 a catchpoint on unhandled exceptions. */
11968 const char *catch_exception_unhandled_sym;
11969
11970 /* The name of the symbol to break on in order to insert
11971 a catchpoint on failed assertions. */
11972 const char *catch_assert_sym;
11973
9f757bf7
XR
11974 /* The name of the symbol to break on in order to insert
11975 a catchpoint on exception handling. */
11976 const char *catch_handlers_sym;
11977
0259addd
JB
11978 /* Assuming that the inferior just triggered an unhandled exception
11979 catchpoint, this function is responsible for returning the address
11980 in inferior memory where the name of that exception is stored.
11981 Return zero if the address could not be computed. */
11982 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11983};
11984
11985static CORE_ADDR ada_unhandled_exception_name_addr (void);
11986static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11987
11988/* The following exception support info structure describes how to
11989 implement exception catchpoints with the latest version of the
11990 Ada runtime (as of 2007-03-06). */
11991
11992static const struct exception_support_info default_exception_support_info =
11993{
11994 "__gnat_debug_raise_exception", /* catch_exception_sym */
11995 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11996 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 11997 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
11998 ada_unhandled_exception_name_addr
11999};
12000
12001/* The following exception support info structure describes how to
12002 implement exception catchpoints with a slightly older version
12003 of the Ada runtime. */
12004
12005static const struct exception_support_info exception_support_info_fallback =
12006{
12007 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12008 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12009 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 12010 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12011 ada_unhandled_exception_name_addr_from_raise
12012};
12013
f17011e0
JB
12014/* Return nonzero if we can detect the exception support routines
12015 described in EINFO.
12016
12017 This function errors out if an abnormal situation is detected
12018 (for instance, if we find the exception support routines, but
12019 that support is found to be incomplete). */
12020
12021static int
12022ada_has_this_exception_support (const struct exception_support_info *einfo)
12023{
12024 struct symbol *sym;
12025
12026 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12027 that should be compiled with debugging information. As a result, we
12028 expect to find that symbol in the symtabs. */
12029
12030 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12031 if (sym == NULL)
a6af7abe
JB
12032 {
12033 /* Perhaps we did not find our symbol because the Ada runtime was
12034 compiled without debugging info, or simply stripped of it.
12035 It happens on some GNU/Linux distributions for instance, where
12036 users have to install a separate debug package in order to get
12037 the runtime's debugging info. In that situation, let the user
12038 know why we cannot insert an Ada exception catchpoint.
12039
12040 Note: Just for the purpose of inserting our Ada exception
12041 catchpoint, we could rely purely on the associated minimal symbol.
12042 But we would be operating in degraded mode anyway, since we are
12043 still lacking the debugging info needed later on to extract
12044 the name of the exception being raised (this name is printed in
12045 the catchpoint message, and is also used when trying to catch
12046 a specific exception). We do not handle this case for now. */
3b7344d5 12047 struct bound_minimal_symbol msym
1c8e84b0
JB
12048 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12049
3b7344d5 12050 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
12051 error (_("Your Ada runtime appears to be missing some debugging "
12052 "information.\nCannot insert Ada exception catchpoint "
12053 "in this configuration."));
12054
12055 return 0;
12056 }
f17011e0
JB
12057
12058 /* Make sure that the symbol we found corresponds to a function. */
12059
12060 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12061 error (_("Symbol \"%s\" is not a function (class = %d)"),
12062 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12063
12064 return 1;
12065}
12066
0259addd
JB
12067/* Inspect the Ada runtime and determine which exception info structure
12068 should be used to provide support for exception catchpoints.
12069
3eecfa55
JB
12070 This function will always set the per-inferior exception_info,
12071 or raise an error. */
0259addd
JB
12072
12073static void
12074ada_exception_support_info_sniffer (void)
12075{
3eecfa55 12076 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
12077
12078 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 12079 if (data->exception_info != NULL)
0259addd
JB
12080 return;
12081
12082 /* Check the latest (default) exception support info. */
f17011e0 12083 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 12084 {
3eecfa55 12085 data->exception_info = &default_exception_support_info;
0259addd
JB
12086 return;
12087 }
12088
12089 /* Try our fallback exception suport info. */
f17011e0 12090 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 12091 {
3eecfa55 12092 data->exception_info = &exception_support_info_fallback;
0259addd
JB
12093 return;
12094 }
12095
12096 /* Sometimes, it is normal for us to not be able to find the routine
12097 we are looking for. This happens when the program is linked with
12098 the shared version of the GNAT runtime, and the program has not been
12099 started yet. Inform the user of these two possible causes if
12100 applicable. */
12101
ccefe4c4 12102 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
12103 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12104
12105 /* If the symbol does not exist, then check that the program is
12106 already started, to make sure that shared libraries have been
12107 loaded. If it is not started, this may mean that the symbol is
12108 in a shared library. */
12109
e99b03dc 12110 if (inferior_ptid.pid () == 0)
0259addd
JB
12111 error (_("Unable to insert catchpoint. Try to start the program first."));
12112
12113 /* At this point, we know that we are debugging an Ada program and
12114 that the inferior has been started, but we still are not able to
0963b4bd 12115 find the run-time symbols. That can mean that we are in
0259addd
JB
12116 configurable run time mode, or that a-except as been optimized
12117 out by the linker... In any case, at this point it is not worth
12118 supporting this feature. */
12119
7dda8cff 12120 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12121}
12122
f7f9143b
JB
12123/* True iff FRAME is very likely to be that of a function that is
12124 part of the runtime system. This is all very heuristic, but is
12125 intended to be used as advice as to what frames are uninteresting
12126 to most users. */
12127
12128static int
12129is_known_support_routine (struct frame_info *frame)
12130{
692465f1 12131 enum language func_lang;
f7f9143b 12132 int i;
f35a17b5 12133 const char *fullname;
f7f9143b 12134
4ed6b5be
JB
12135 /* If this code does not have any debugging information (no symtab),
12136 This cannot be any user code. */
f7f9143b 12137
51abb421 12138 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12139 if (sal.symtab == NULL)
12140 return 1;
12141
4ed6b5be
JB
12142 /* If there is a symtab, but the associated source file cannot be
12143 located, then assume this is not user code: Selecting a frame
12144 for which we cannot display the code would not be very helpful
12145 for the user. This should also take care of case such as VxWorks
12146 where the kernel has some debugging info provided for a few units. */
f7f9143b 12147
f35a17b5
JK
12148 fullname = symtab_to_fullname (sal.symtab);
12149 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12150 return 1;
12151
4ed6b5be
JB
12152 /* Check the unit filename againt the Ada runtime file naming.
12153 We also check the name of the objfile against the name of some
12154 known system libraries that sometimes come with debugging info
12155 too. */
12156
f7f9143b
JB
12157 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12158 {
12159 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12160 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12161 return 1;
eb822aa6
DE
12162 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12163 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12164 return 1;
f7f9143b
JB
12165 }
12166
4ed6b5be 12167 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12168
c6dc63a1
TT
12169 gdb::unique_xmalloc_ptr<char> func_name
12170 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12171 if (func_name == NULL)
12172 return 1;
12173
12174 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12175 {
12176 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12177 if (re_exec (func_name.get ()))
12178 return 1;
f7f9143b
JB
12179 }
12180
12181 return 0;
12182}
12183
12184/* Find the first frame that contains debugging information and that is not
12185 part of the Ada run-time, starting from FI and moving upward. */
12186
0ef643c8 12187void
f7f9143b
JB
12188ada_find_printable_frame (struct frame_info *fi)
12189{
12190 for (; fi != NULL; fi = get_prev_frame (fi))
12191 {
12192 if (!is_known_support_routine (fi))
12193 {
12194 select_frame (fi);
12195 break;
12196 }
12197 }
12198
12199}
12200
12201/* Assuming that the inferior just triggered an unhandled exception
12202 catchpoint, return the address in inferior memory where the name
12203 of the exception is stored.
12204
12205 Return zero if the address could not be computed. */
12206
12207static CORE_ADDR
12208ada_unhandled_exception_name_addr (void)
0259addd
JB
12209{
12210 return parse_and_eval_address ("e.full_name");
12211}
12212
12213/* Same as ada_unhandled_exception_name_addr, except that this function
12214 should be used when the inferior uses an older version of the runtime,
12215 where the exception name needs to be extracted from a specific frame
12216 several frames up in the callstack. */
12217
12218static CORE_ADDR
12219ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12220{
12221 int frame_level;
12222 struct frame_info *fi;
3eecfa55 12223 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12224
12225 /* To determine the name of this exception, we need to select
12226 the frame corresponding to RAISE_SYM_NAME. This frame is
12227 at least 3 levels up, so we simply skip the first 3 frames
12228 without checking the name of their associated function. */
12229 fi = get_current_frame ();
12230 for (frame_level = 0; frame_level < 3; frame_level += 1)
12231 if (fi != NULL)
12232 fi = get_prev_frame (fi);
12233
12234 while (fi != NULL)
12235 {
692465f1
JB
12236 enum language func_lang;
12237
c6dc63a1
TT
12238 gdb::unique_xmalloc_ptr<char> func_name
12239 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12240 if (func_name != NULL)
12241 {
c6dc63a1 12242 if (strcmp (func_name.get (),
55b87a52
KS
12243 data->exception_info->catch_exception_sym) == 0)
12244 break; /* We found the frame we were looking for... */
55b87a52 12245 }
fb44b1a7 12246 fi = get_prev_frame (fi);
f7f9143b
JB
12247 }
12248
12249 if (fi == NULL)
12250 return 0;
12251
12252 select_frame (fi);
12253 return parse_and_eval_address ("id.full_name");
12254}
12255
12256/* Assuming the inferior just triggered an Ada exception catchpoint
12257 (of any type), return the address in inferior memory where the name
12258 of the exception is stored, if applicable.
12259
45db7c09
PA
12260 Assumes the selected frame is the current frame.
12261
f7f9143b
JB
12262 Return zero if the address could not be computed, or if not relevant. */
12263
12264static CORE_ADDR
761269c8 12265ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12266 struct breakpoint *b)
12267{
3eecfa55
JB
12268 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12269
f7f9143b
JB
12270 switch (ex)
12271 {
761269c8 12272 case ada_catch_exception:
f7f9143b
JB
12273 return (parse_and_eval_address ("e.full_name"));
12274 break;
12275
761269c8 12276 case ada_catch_exception_unhandled:
3eecfa55 12277 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12278 break;
9f757bf7
XR
12279
12280 case ada_catch_handlers:
12281 return 0; /* The runtimes does not provide access to the exception
12282 name. */
12283 break;
12284
761269c8 12285 case ada_catch_assert:
f7f9143b
JB
12286 return 0; /* Exception name is not relevant in this case. */
12287 break;
12288
12289 default:
12290 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12291 break;
12292 }
12293
12294 return 0; /* Should never be reached. */
12295}
12296
e547c119
JB
12297/* Assuming the inferior is stopped at an exception catchpoint,
12298 return the message which was associated to the exception, if
12299 available. Return NULL if the message could not be retrieved.
12300
e547c119
JB
12301 Note: The exception message can be associated to an exception
12302 either through the use of the Raise_Exception function, or
12303 more simply (Ada 2005 and later), via:
12304
12305 raise Exception_Name with "exception message";
12306
12307 */
12308
6f46ac85 12309static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12310ada_exception_message_1 (void)
12311{
12312 struct value *e_msg_val;
e547c119 12313 int e_msg_len;
e547c119
JB
12314
12315 /* For runtimes that support this feature, the exception message
12316 is passed as an unbounded string argument called "message". */
12317 e_msg_val = parse_and_eval ("message");
12318 if (e_msg_val == NULL)
12319 return NULL; /* Exception message not supported. */
12320
12321 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12322 gdb_assert (e_msg_val != NULL);
12323 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12324
12325 /* If the message string is empty, then treat it as if there was
12326 no exception message. */
12327 if (e_msg_len <= 0)
12328 return NULL;
12329
6f46ac85
TT
12330 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12331 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12332 e_msg.get ()[e_msg_len] = '\0';
e547c119 12333
e547c119
JB
12334 return e_msg;
12335}
12336
12337/* Same as ada_exception_message_1, except that all exceptions are
12338 contained here (returning NULL instead). */
12339
6f46ac85 12340static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12341ada_exception_message (void)
12342{
6f46ac85 12343 gdb::unique_xmalloc_ptr<char> e_msg;
e547c119
JB
12344
12345 TRY
12346 {
12347 e_msg = ada_exception_message_1 ();
12348 }
12349 CATCH (e, RETURN_MASK_ERROR)
12350 {
6f46ac85 12351 e_msg.reset (nullptr);
e547c119
JB
12352 }
12353 END_CATCH
12354
12355 return e_msg;
12356}
12357
f7f9143b
JB
12358/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12359 any error that ada_exception_name_addr_1 might cause to be thrown.
12360 When an error is intercepted, a warning with the error message is printed,
12361 and zero is returned. */
12362
12363static CORE_ADDR
761269c8 12364ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12365 struct breakpoint *b)
12366{
f7f9143b
JB
12367 CORE_ADDR result = 0;
12368
492d29ea 12369 TRY
f7f9143b
JB
12370 {
12371 result = ada_exception_name_addr_1 (ex, b);
12372 }
12373
492d29ea 12374 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12375 {
12376 warning (_("failed to get exception name: %s"), e.message);
12377 return 0;
12378 }
492d29ea 12379 END_CATCH
f7f9143b
JB
12380
12381 return result;
12382}
12383
cb7de75e 12384static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12385 (const char *excep_string,
12386 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12387
12388/* Ada catchpoints.
12389
12390 In the case of catchpoints on Ada exceptions, the catchpoint will
12391 stop the target on every exception the program throws. When a user
12392 specifies the name of a specific exception, we translate this
12393 request into a condition expression (in text form), and then parse
12394 it into an expression stored in each of the catchpoint's locations.
12395 We then use this condition to check whether the exception that was
12396 raised is the one the user is interested in. If not, then the
12397 target is resumed again. We store the name of the requested
12398 exception, in order to be able to re-set the condition expression
12399 when symbols change. */
12400
12401/* An instance of this type is used to represent an Ada catchpoint
5625a286 12402 breakpoint location. */
28010a5d 12403
5625a286 12404class ada_catchpoint_location : public bp_location
28010a5d 12405{
5625a286
PA
12406public:
12407 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12408 : bp_location (ops, owner)
12409 {}
28010a5d
PA
12410
12411 /* The condition that checks whether the exception that was raised
12412 is the specific exception the user specified on catchpoint
12413 creation. */
4d01a485 12414 expression_up excep_cond_expr;
28010a5d
PA
12415};
12416
12417/* Implement the DTOR method in the bp_location_ops structure for all
12418 Ada exception catchpoint kinds. */
12419
12420static void
12421ada_catchpoint_location_dtor (struct bp_location *bl)
12422{
12423 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12424
4d01a485 12425 al->excep_cond_expr.reset ();
28010a5d
PA
12426}
12427
12428/* The vtable to be used in Ada catchpoint locations. */
12429
12430static const struct bp_location_ops ada_catchpoint_location_ops =
12431{
12432 ada_catchpoint_location_dtor
12433};
12434
c1fc2657 12435/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12436
c1fc2657 12437struct ada_catchpoint : public breakpoint
28010a5d 12438{
28010a5d 12439 /* The name of the specific exception the user specified. */
bc18fbb5 12440 std::string excep_string;
28010a5d
PA
12441};
12442
12443/* Parse the exception condition string in the context of each of the
12444 catchpoint's locations, and store them for later evaluation. */
12445
12446static void
9f757bf7
XR
12447create_excep_cond_exprs (struct ada_catchpoint *c,
12448 enum ada_exception_catchpoint_kind ex)
28010a5d 12449{
28010a5d 12450 struct bp_location *bl;
28010a5d
PA
12451
12452 /* Nothing to do if there's no specific exception to catch. */
bc18fbb5 12453 if (c->excep_string.empty ())
28010a5d
PA
12454 return;
12455
12456 /* Same if there are no locations... */
c1fc2657 12457 if (c->loc == NULL)
28010a5d
PA
12458 return;
12459
12460 /* Compute the condition expression in text form, from the specific
12461 expection we want to catch. */
cb7de75e 12462 std::string cond_string
bc18fbb5 12463 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
28010a5d
PA
12464
12465 /* Iterate over all the catchpoint's locations, and parse an
12466 expression for each. */
c1fc2657 12467 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12468 {
12469 struct ada_catchpoint_location *ada_loc
12470 = (struct ada_catchpoint_location *) bl;
4d01a485 12471 expression_up exp;
28010a5d
PA
12472
12473 if (!bl->shlib_disabled)
12474 {
bbc13ae3 12475 const char *s;
28010a5d 12476
cb7de75e 12477 s = cond_string.c_str ();
492d29ea 12478 TRY
28010a5d 12479 {
036e657b
JB
12480 exp = parse_exp_1 (&s, bl->address,
12481 block_for_pc (bl->address),
12482 0);
28010a5d 12483 }
492d29ea 12484 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12485 {
12486 warning (_("failed to reevaluate internal exception condition "
12487 "for catchpoint %d: %s"),
c1fc2657 12488 c->number, e.message);
849f2b52 12489 }
492d29ea 12490 END_CATCH
28010a5d
PA
12491 }
12492
b22e99fd 12493 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12494 }
28010a5d
PA
12495}
12496
28010a5d
PA
12497/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12498 structure for all exception catchpoint kinds. */
12499
12500static struct bp_location *
761269c8 12501allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12502 struct breakpoint *self)
12503{
5625a286 12504 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12505}
12506
12507/* Implement the RE_SET method in the breakpoint_ops structure for all
12508 exception catchpoint kinds. */
12509
12510static void
761269c8 12511re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12512{
12513 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12514
12515 /* Call the base class's method. This updates the catchpoint's
12516 locations. */
2060206e 12517 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12518
12519 /* Reparse the exception conditional expressions. One for each
12520 location. */
9f757bf7 12521 create_excep_cond_exprs (c, ex);
28010a5d
PA
12522}
12523
12524/* Returns true if we should stop for this breakpoint hit. If the
12525 user specified a specific exception, we only want to cause a stop
12526 if the program thrown that exception. */
12527
12528static int
12529should_stop_exception (const struct bp_location *bl)
12530{
12531 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12532 const struct ada_catchpoint_location *ada_loc
12533 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12534 int stop;
12535
12536 /* With no specific exception, should always stop. */
bc18fbb5 12537 if (c->excep_string.empty ())
28010a5d
PA
12538 return 1;
12539
12540 if (ada_loc->excep_cond_expr == NULL)
12541 {
12542 /* We will have a NULL expression if back when we were creating
12543 the expressions, this location's had failed to parse. */
12544 return 1;
12545 }
12546
12547 stop = 1;
492d29ea 12548 TRY
28010a5d
PA
12549 {
12550 struct value *mark;
12551
12552 mark = value_mark ();
4d01a485 12553 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12554 value_free_to_mark (mark);
12555 }
492d29ea
PA
12556 CATCH (ex, RETURN_MASK_ALL)
12557 {
12558 exception_fprintf (gdb_stderr, ex,
12559 _("Error in testing exception condition:\n"));
12560 }
12561 END_CATCH
12562
28010a5d
PA
12563 return stop;
12564}
12565
12566/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12567 for all exception catchpoint kinds. */
12568
12569static void
761269c8 12570check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12571{
12572 bs->stop = should_stop_exception (bs->bp_location_at);
12573}
12574
f7f9143b
JB
12575/* Implement the PRINT_IT method in the breakpoint_ops structure
12576 for all exception catchpoint kinds. */
12577
12578static enum print_stop_action
761269c8 12579print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12580{
79a45e25 12581 struct ui_out *uiout = current_uiout;
348d480f
PA
12582 struct breakpoint *b = bs->breakpoint_at;
12583
956a9fb9 12584 annotate_catchpoint (b->number);
f7f9143b 12585
112e8700 12586 if (uiout->is_mi_like_p ())
f7f9143b 12587 {
112e8700 12588 uiout->field_string ("reason",
956a9fb9 12589 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12590 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12591 }
12592
112e8700
SM
12593 uiout->text (b->disposition == disp_del
12594 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12595 uiout->field_int ("bkptno", b->number);
12596 uiout->text (", ");
f7f9143b 12597
45db7c09
PA
12598 /* ada_exception_name_addr relies on the selected frame being the
12599 current frame. Need to do this here because this function may be
12600 called more than once when printing a stop, and below, we'll
12601 select the first frame past the Ada run-time (see
12602 ada_find_printable_frame). */
12603 select_frame (get_current_frame ());
12604
f7f9143b
JB
12605 switch (ex)
12606 {
761269c8
JB
12607 case ada_catch_exception:
12608 case ada_catch_exception_unhandled:
9f757bf7 12609 case ada_catch_handlers:
956a9fb9
JB
12610 {
12611 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12612 char exception_name[256];
12613
12614 if (addr != 0)
12615 {
c714b426
PA
12616 read_memory (addr, (gdb_byte *) exception_name,
12617 sizeof (exception_name) - 1);
956a9fb9
JB
12618 exception_name [sizeof (exception_name) - 1] = '\0';
12619 }
12620 else
12621 {
12622 /* For some reason, we were unable to read the exception
12623 name. This could happen if the Runtime was compiled
12624 without debugging info, for instance. In that case,
12625 just replace the exception name by the generic string
12626 "exception" - it will read as "an exception" in the
12627 notification we are about to print. */
967cff16 12628 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12629 }
12630 /* In the case of unhandled exception breakpoints, we print
12631 the exception name as "unhandled EXCEPTION_NAME", to make
12632 it clearer to the user which kind of catchpoint just got
12633 hit. We used ui_out_text to make sure that this extra
12634 info does not pollute the exception name in the MI case. */
761269c8 12635 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12636 uiout->text ("unhandled ");
12637 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12638 }
12639 break;
761269c8 12640 case ada_catch_assert:
956a9fb9
JB
12641 /* In this case, the name of the exception is not really
12642 important. Just print "failed assertion" to make it clearer
12643 that his program just hit an assertion-failure catchpoint.
12644 We used ui_out_text because this info does not belong in
12645 the MI output. */
112e8700 12646 uiout->text ("failed assertion");
956a9fb9 12647 break;
f7f9143b 12648 }
e547c119 12649
6f46ac85 12650 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
e547c119
JB
12651 if (exception_message != NULL)
12652 {
e547c119 12653 uiout->text (" (");
6f46ac85 12654 uiout->field_string ("exception-message", exception_message.get ());
e547c119 12655 uiout->text (")");
e547c119
JB
12656 }
12657
112e8700 12658 uiout->text (" at ");
956a9fb9 12659 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12660
12661 return PRINT_SRC_AND_LOC;
12662}
12663
12664/* Implement the PRINT_ONE method in the breakpoint_ops structure
12665 for all exception catchpoint kinds. */
12666
12667static void
761269c8 12668print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12669 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12670{
79a45e25 12671 struct ui_out *uiout = current_uiout;
28010a5d 12672 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12673 struct value_print_options opts;
12674
12675 get_user_print_options (&opts);
12676 if (opts.addressprint)
f7f9143b
JB
12677 {
12678 annotate_field (4);
112e8700 12679 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12680 }
12681
12682 annotate_field (5);
a6d9a66e 12683 *last_loc = b->loc;
f7f9143b
JB
12684 switch (ex)
12685 {
761269c8 12686 case ada_catch_exception:
bc18fbb5 12687 if (!c->excep_string.empty ())
f7f9143b 12688 {
bc18fbb5
TT
12689 std::string msg = string_printf (_("`%s' Ada exception"),
12690 c->excep_string.c_str ());
28010a5d 12691
112e8700 12692 uiout->field_string ("what", msg);
f7f9143b
JB
12693 }
12694 else
112e8700 12695 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12696
12697 break;
12698
761269c8 12699 case ada_catch_exception_unhandled:
112e8700 12700 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12701 break;
12702
9f757bf7 12703 case ada_catch_handlers:
bc18fbb5 12704 if (!c->excep_string.empty ())
9f757bf7
XR
12705 {
12706 uiout->field_fmt ("what",
12707 _("`%s' Ada exception handlers"),
bc18fbb5 12708 c->excep_string.c_str ());
9f757bf7
XR
12709 }
12710 else
12711 uiout->field_string ("what", "all Ada exceptions handlers");
12712 break;
12713
761269c8 12714 case ada_catch_assert:
112e8700 12715 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12716 break;
12717
12718 default:
12719 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12720 break;
12721 }
12722}
12723
12724/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12725 for all exception catchpoint kinds. */
12726
12727static void
761269c8 12728print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12729 struct breakpoint *b)
12730{
28010a5d 12731 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12732 struct ui_out *uiout = current_uiout;
28010a5d 12733
112e8700 12734 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12735 : _("Catchpoint "));
112e8700
SM
12736 uiout->field_int ("bkptno", b->number);
12737 uiout->text (": ");
00eb2c4a 12738
f7f9143b
JB
12739 switch (ex)
12740 {
761269c8 12741 case ada_catch_exception:
bc18fbb5 12742 if (!c->excep_string.empty ())
00eb2c4a 12743 {
862d101a 12744 std::string info = string_printf (_("`%s' Ada exception"),
bc18fbb5 12745 c->excep_string.c_str ());
862d101a 12746 uiout->text (info.c_str ());
00eb2c4a 12747 }
f7f9143b 12748 else
112e8700 12749 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12750 break;
12751
761269c8 12752 case ada_catch_exception_unhandled:
112e8700 12753 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12754 break;
9f757bf7
XR
12755
12756 case ada_catch_handlers:
bc18fbb5 12757 if (!c->excep_string.empty ())
9f757bf7
XR
12758 {
12759 std::string info
12760 = string_printf (_("`%s' Ada exception handlers"),
bc18fbb5 12761 c->excep_string.c_str ());
9f757bf7
XR
12762 uiout->text (info.c_str ());
12763 }
12764 else
12765 uiout->text (_("all Ada exceptions handlers"));
12766 break;
12767
761269c8 12768 case ada_catch_assert:
112e8700 12769 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12770 break;
12771
12772 default:
12773 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12774 break;
12775 }
12776}
12777
6149aea9
PA
12778/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12779 for all exception catchpoint kinds. */
12780
12781static void
761269c8 12782print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12783 struct breakpoint *b, struct ui_file *fp)
12784{
28010a5d
PA
12785 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12786
6149aea9
PA
12787 switch (ex)
12788 {
761269c8 12789 case ada_catch_exception:
6149aea9 12790 fprintf_filtered (fp, "catch exception");
bc18fbb5
TT
12791 if (!c->excep_string.empty ())
12792 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
6149aea9
PA
12793 break;
12794
761269c8 12795 case ada_catch_exception_unhandled:
78076abc 12796 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12797 break;
12798
9f757bf7
XR
12799 case ada_catch_handlers:
12800 fprintf_filtered (fp, "catch handlers");
12801 break;
12802
761269c8 12803 case ada_catch_assert:
6149aea9
PA
12804 fprintf_filtered (fp, "catch assert");
12805 break;
12806
12807 default:
12808 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12809 }
d9b3f62e 12810 print_recreate_thread (b, fp);
6149aea9
PA
12811}
12812
f7f9143b
JB
12813/* Virtual table for "catch exception" breakpoints. */
12814
28010a5d
PA
12815static struct bp_location *
12816allocate_location_catch_exception (struct breakpoint *self)
12817{
761269c8 12818 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12819}
12820
12821static void
12822re_set_catch_exception (struct breakpoint *b)
12823{
761269c8 12824 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12825}
12826
12827static void
12828check_status_catch_exception (bpstat bs)
12829{
761269c8 12830 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12831}
12832
f7f9143b 12833static enum print_stop_action
348d480f 12834print_it_catch_exception (bpstat bs)
f7f9143b 12835{
761269c8 12836 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12837}
12838
12839static void
a6d9a66e 12840print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12841{
761269c8 12842 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12843}
12844
12845static void
12846print_mention_catch_exception (struct breakpoint *b)
12847{
761269c8 12848 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12849}
12850
6149aea9
PA
12851static void
12852print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12853{
761269c8 12854 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12855}
12856
2060206e 12857static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12858
12859/* Virtual table for "catch exception unhandled" breakpoints. */
12860
28010a5d
PA
12861static struct bp_location *
12862allocate_location_catch_exception_unhandled (struct breakpoint *self)
12863{
761269c8 12864 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12865}
12866
12867static void
12868re_set_catch_exception_unhandled (struct breakpoint *b)
12869{
761269c8 12870 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12871}
12872
12873static void
12874check_status_catch_exception_unhandled (bpstat bs)
12875{
761269c8 12876 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12877}
12878
f7f9143b 12879static enum print_stop_action
348d480f 12880print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12881{
761269c8 12882 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12883}
12884
12885static void
a6d9a66e
UW
12886print_one_catch_exception_unhandled (struct breakpoint *b,
12887 struct bp_location **last_loc)
f7f9143b 12888{
761269c8 12889 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12890}
12891
12892static void
12893print_mention_catch_exception_unhandled (struct breakpoint *b)
12894{
761269c8 12895 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12896}
12897
6149aea9
PA
12898static void
12899print_recreate_catch_exception_unhandled (struct breakpoint *b,
12900 struct ui_file *fp)
12901{
761269c8 12902 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12903}
12904
2060206e 12905static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12906
12907/* Virtual table for "catch assert" breakpoints. */
12908
28010a5d
PA
12909static struct bp_location *
12910allocate_location_catch_assert (struct breakpoint *self)
12911{
761269c8 12912 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12913}
12914
12915static void
12916re_set_catch_assert (struct breakpoint *b)
12917{
761269c8 12918 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12919}
12920
12921static void
12922check_status_catch_assert (bpstat bs)
12923{
761269c8 12924 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12925}
12926
f7f9143b 12927static enum print_stop_action
348d480f 12928print_it_catch_assert (bpstat bs)
f7f9143b 12929{
761269c8 12930 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12931}
12932
12933static void
a6d9a66e 12934print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12935{
761269c8 12936 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12937}
12938
12939static void
12940print_mention_catch_assert (struct breakpoint *b)
12941{
761269c8 12942 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12943}
12944
6149aea9
PA
12945static void
12946print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12947{
761269c8 12948 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12949}
12950
2060206e 12951static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12952
9f757bf7
XR
12953/* Virtual table for "catch handlers" breakpoints. */
12954
12955static struct bp_location *
12956allocate_location_catch_handlers (struct breakpoint *self)
12957{
12958 return allocate_location_exception (ada_catch_handlers, self);
12959}
12960
12961static void
12962re_set_catch_handlers (struct breakpoint *b)
12963{
12964 re_set_exception (ada_catch_handlers, b);
12965}
12966
12967static void
12968check_status_catch_handlers (bpstat bs)
12969{
12970 check_status_exception (ada_catch_handlers, bs);
12971}
12972
12973static enum print_stop_action
12974print_it_catch_handlers (bpstat bs)
12975{
12976 return print_it_exception (ada_catch_handlers, bs);
12977}
12978
12979static void
12980print_one_catch_handlers (struct breakpoint *b,
12981 struct bp_location **last_loc)
12982{
12983 print_one_exception (ada_catch_handlers, b, last_loc);
12984}
12985
12986static void
12987print_mention_catch_handlers (struct breakpoint *b)
12988{
12989 print_mention_exception (ada_catch_handlers, b);
12990}
12991
12992static void
12993print_recreate_catch_handlers (struct breakpoint *b,
12994 struct ui_file *fp)
12995{
12996 print_recreate_exception (ada_catch_handlers, b, fp);
12997}
12998
12999static struct breakpoint_ops catch_handlers_breakpoint_ops;
13000
f7f9143b
JB
13001/* Split the arguments specified in a "catch exception" command.
13002 Set EX to the appropriate catchpoint type.
28010a5d 13003 Set EXCEP_STRING to the name of the specific exception if
5845583d 13004 specified by the user.
9f757bf7
XR
13005 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13006 "catch handlers" command. False otherwise.
5845583d
JB
13007 If a condition is found at the end of the arguments, the condition
13008 expression is stored in COND_STRING (memory must be deallocated
13009 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
13010
13011static void
a121b7c1 13012catch_ada_exception_command_split (const char *args,
9f757bf7 13013 bool is_catch_handlers_cmd,
761269c8 13014 enum ada_exception_catchpoint_kind *ex,
bc18fbb5
TT
13015 std::string *excep_string,
13016 std::string *cond_string)
f7f9143b 13017{
bc18fbb5 13018 std::string exception_name;
f7f9143b 13019
bc18fbb5
TT
13020 exception_name = extract_arg (&args);
13021 if (exception_name == "if")
5845583d
JB
13022 {
13023 /* This is not an exception name; this is the start of a condition
13024 expression for a catchpoint on all exceptions. So, "un-get"
13025 this token, and set exception_name to NULL. */
bc18fbb5 13026 exception_name.clear ();
5845583d
JB
13027 args -= 2;
13028 }
f7f9143b 13029
5845583d 13030 /* Check to see if we have a condition. */
f7f9143b 13031
f1735a53 13032 args = skip_spaces (args);
61012eef 13033 if (startswith (args, "if")
5845583d
JB
13034 && (isspace (args[2]) || args[2] == '\0'))
13035 {
13036 args += 2;
f1735a53 13037 args = skip_spaces (args);
5845583d
JB
13038
13039 if (args[0] == '\0')
13040 error (_("Condition missing after `if' keyword"));
bc18fbb5 13041 *cond_string = args;
5845583d
JB
13042
13043 args += strlen (args);
13044 }
13045
13046 /* Check that we do not have any more arguments. Anything else
13047 is unexpected. */
f7f9143b
JB
13048
13049 if (args[0] != '\0')
13050 error (_("Junk at end of expression"));
13051
9f757bf7
XR
13052 if (is_catch_handlers_cmd)
13053 {
13054 /* Catch handling of exceptions. */
13055 *ex = ada_catch_handlers;
13056 *excep_string = exception_name;
13057 }
bc18fbb5 13058 else if (exception_name.empty ())
f7f9143b
JB
13059 {
13060 /* Catch all exceptions. */
761269c8 13061 *ex = ada_catch_exception;
bc18fbb5 13062 excep_string->clear ();
f7f9143b 13063 }
bc18fbb5 13064 else if (exception_name == "unhandled")
f7f9143b
JB
13065 {
13066 /* Catch unhandled exceptions. */
761269c8 13067 *ex = ada_catch_exception_unhandled;
bc18fbb5 13068 excep_string->clear ();
f7f9143b
JB
13069 }
13070 else
13071 {
13072 /* Catch a specific exception. */
761269c8 13073 *ex = ada_catch_exception;
28010a5d 13074 *excep_string = exception_name;
f7f9143b
JB
13075 }
13076}
13077
13078/* Return the name of the symbol on which we should break in order to
13079 implement a catchpoint of the EX kind. */
13080
13081static const char *
761269c8 13082ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 13083{
3eecfa55
JB
13084 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13085
13086 gdb_assert (data->exception_info != NULL);
0259addd 13087
f7f9143b
JB
13088 switch (ex)
13089 {
761269c8 13090 case ada_catch_exception:
3eecfa55 13091 return (data->exception_info->catch_exception_sym);
f7f9143b 13092 break;
761269c8 13093 case ada_catch_exception_unhandled:
3eecfa55 13094 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 13095 break;
761269c8 13096 case ada_catch_assert:
3eecfa55 13097 return (data->exception_info->catch_assert_sym);
f7f9143b 13098 break;
9f757bf7
XR
13099 case ada_catch_handlers:
13100 return (data->exception_info->catch_handlers_sym);
13101 break;
f7f9143b
JB
13102 default:
13103 internal_error (__FILE__, __LINE__,
13104 _("unexpected catchpoint kind (%d)"), ex);
13105 }
13106}
13107
13108/* Return the breakpoint ops "virtual table" used for catchpoints
13109 of the EX kind. */
13110
c0a91b2b 13111static const struct breakpoint_ops *
761269c8 13112ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
13113{
13114 switch (ex)
13115 {
761269c8 13116 case ada_catch_exception:
f7f9143b
JB
13117 return (&catch_exception_breakpoint_ops);
13118 break;
761269c8 13119 case ada_catch_exception_unhandled:
f7f9143b
JB
13120 return (&catch_exception_unhandled_breakpoint_ops);
13121 break;
761269c8 13122 case ada_catch_assert:
f7f9143b
JB
13123 return (&catch_assert_breakpoint_ops);
13124 break;
9f757bf7
XR
13125 case ada_catch_handlers:
13126 return (&catch_handlers_breakpoint_ops);
13127 break;
f7f9143b
JB
13128 default:
13129 internal_error (__FILE__, __LINE__,
13130 _("unexpected catchpoint kind (%d)"), ex);
13131 }
13132}
13133
13134/* Return the condition that will be used to match the current exception
13135 being raised with the exception that the user wants to catch. This
13136 assumes that this condition is used when the inferior just triggered
13137 an exception catchpoint.
cb7de75e 13138 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 13139
cb7de75e 13140static std::string
9f757bf7
XR
13141ada_exception_catchpoint_cond_string (const char *excep_string,
13142 enum ada_exception_catchpoint_kind ex)
f7f9143b 13143{
3d0b0fa3 13144 int i;
9f757bf7 13145 bool is_standard_exc = false;
cb7de75e 13146 std::string result;
9f757bf7
XR
13147
13148 if (ex == ada_catch_handlers)
13149 {
13150 /* For exception handlers catchpoints, the condition string does
13151 not use the same parameter as for the other exceptions. */
cb7de75e
TT
13152 result = ("long_integer (GNAT_GCC_exception_Access"
13153 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13154 }
13155 else
cb7de75e 13156 result = "long_integer (e)";
3d0b0fa3 13157
0963b4bd 13158 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13159 runtime units that have been compiled without debugging info; if
28010a5d 13160 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13161 exception (e.g. "constraint_error") then, during the evaluation
13162 of the condition expression, the symbol lookup on this name would
0963b4bd 13163 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13164 may then be set only on user-defined exceptions which have the
13165 same not-fully-qualified name (e.g. my_package.constraint_error).
13166
13167 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13168 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13169 exception constraint_error" is rewritten into "catch exception
13170 standard.constraint_error".
13171
13172 If an exception named contraint_error is defined in another package of
13173 the inferior program, then the only way to specify this exception as a
13174 breakpoint condition is to use its fully-qualified named:
13175 e.g. my_package.constraint_error. */
13176
13177 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13178 {
28010a5d 13179 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13180 {
9f757bf7
XR
13181 is_standard_exc = true;
13182 break;
3d0b0fa3
JB
13183 }
13184 }
9f757bf7 13185
cb7de75e
TT
13186 result += " = ";
13187
9f757bf7 13188 if (is_standard_exc)
cb7de75e 13189 string_appendf (result, "long_integer (&standard.%s)", excep_string);
9f757bf7 13190 else
cb7de75e 13191 string_appendf (result, "long_integer (&%s)", excep_string);
9f757bf7 13192
9f757bf7 13193 return result;
f7f9143b
JB
13194}
13195
13196/* Return the symtab_and_line that should be used to insert an exception
13197 catchpoint of the TYPE kind.
13198
28010a5d
PA
13199 ADDR_STRING returns the name of the function where the real
13200 breakpoint that implements the catchpoints is set, depending on the
13201 type of catchpoint we need to create. */
f7f9143b
JB
13202
13203static struct symtab_and_line
bc18fbb5 13204ada_exception_sal (enum ada_exception_catchpoint_kind ex,
f2fc3015 13205 const char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13206{
13207 const char *sym_name;
13208 struct symbol *sym;
f7f9143b 13209
0259addd
JB
13210 /* First, find out which exception support info to use. */
13211 ada_exception_support_info_sniffer ();
13212
13213 /* Then lookup the function on which we will break in order to catch
f7f9143b 13214 the Ada exceptions requested by the user. */
f7f9143b
JB
13215 sym_name = ada_exception_sym_name (ex);
13216 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13217
57aff202
JB
13218 if (sym == NULL)
13219 error (_("Catchpoint symbol not found: %s"), sym_name);
13220
13221 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13222 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
f7f9143b
JB
13223
13224 /* Set ADDR_STRING. */
f7f9143b
JB
13225 *addr_string = xstrdup (sym_name);
13226
f7f9143b 13227 /* Set OPS. */
4b9eee8c 13228 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13229
f17011e0 13230 return find_function_start_sal (sym, 1);
f7f9143b
JB
13231}
13232
b4a5b78b 13233/* Create an Ada exception catchpoint.
f7f9143b 13234
b4a5b78b 13235 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13236
bc18fbb5 13237 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
2df4d1d5 13238 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
bc18fbb5 13239 of the exception to which this catchpoint applies.
2df4d1d5 13240
bc18fbb5 13241 COND_STRING, if not empty, is the catchpoint condition.
f7f9143b 13242
b4a5b78b
JB
13243 TEMPFLAG, if nonzero, means that the underlying breakpoint
13244 should be temporary.
28010a5d 13245
b4a5b78b 13246 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13247
349774ef 13248void
28010a5d 13249create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13250 enum ada_exception_catchpoint_kind ex_kind,
bc18fbb5 13251 const std::string &excep_string,
56ecd069 13252 const std::string &cond_string,
28010a5d 13253 int tempflag,
349774ef 13254 int disabled,
28010a5d
PA
13255 int from_tty)
13256{
f2fc3015 13257 const char *addr_string = NULL;
b4a5b78b 13258 const struct breakpoint_ops *ops = NULL;
bc18fbb5 13259 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
28010a5d 13260
b270e6f9
TT
13261 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13262 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
349774ef 13263 ops, tempflag, disabled, from_tty);
28010a5d 13264 c->excep_string = excep_string;
9f757bf7 13265 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13266 if (!cond_string.empty ())
13267 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13268 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13269}
13270
9ac4176b
PA
13271/* Implement the "catch exception" command. */
13272
13273static void
eb4c3f4a 13274catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13275 struct cmd_list_element *command)
13276{
a121b7c1 13277 const char *arg = arg_entry;
9ac4176b
PA
13278 struct gdbarch *gdbarch = get_current_arch ();
13279 int tempflag;
761269c8 13280 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13281 std::string excep_string;
56ecd069 13282 std::string cond_string;
9ac4176b
PA
13283
13284 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13285
13286 if (!arg)
13287 arg = "";
9f757bf7 13288 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
bc18fbb5 13289 &cond_string);
9f757bf7
XR
13290 create_ada_exception_catchpoint (gdbarch, ex_kind,
13291 excep_string, cond_string,
13292 tempflag, 1 /* enabled */,
13293 from_tty);
13294}
13295
13296/* Implement the "catch handlers" command. */
13297
13298static void
13299catch_ada_handlers_command (const char *arg_entry, int from_tty,
13300 struct cmd_list_element *command)
13301{
13302 const char *arg = arg_entry;
13303 struct gdbarch *gdbarch = get_current_arch ();
13304 int tempflag;
13305 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13306 std::string excep_string;
56ecd069 13307 std::string cond_string;
9f757bf7
XR
13308
13309 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13310
13311 if (!arg)
13312 arg = "";
13313 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
bc18fbb5 13314 &cond_string);
b4a5b78b
JB
13315 create_ada_exception_catchpoint (gdbarch, ex_kind,
13316 excep_string, cond_string,
349774ef
JB
13317 tempflag, 1 /* enabled */,
13318 from_tty);
9ac4176b
PA
13319}
13320
b4a5b78b 13321/* Split the arguments specified in a "catch assert" command.
5845583d 13322
b4a5b78b
JB
13323 ARGS contains the command's arguments (or the empty string if
13324 no arguments were passed).
5845583d
JB
13325
13326 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13327 (the memory needs to be deallocated after use). */
5845583d 13328
b4a5b78b 13329static void
56ecd069 13330catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13331{
f1735a53 13332 args = skip_spaces (args);
f7f9143b 13333
5845583d 13334 /* Check whether a condition was provided. */
61012eef 13335 if (startswith (args, "if")
5845583d 13336 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13337 {
5845583d 13338 args += 2;
f1735a53 13339 args = skip_spaces (args);
5845583d
JB
13340 if (args[0] == '\0')
13341 error (_("condition missing after `if' keyword"));
56ecd069 13342 cond_string.assign (args);
f7f9143b
JB
13343 }
13344
5845583d
JB
13345 /* Otherwise, there should be no other argument at the end of
13346 the command. */
13347 else if (args[0] != '\0')
13348 error (_("Junk at end of arguments."));
f7f9143b
JB
13349}
13350
9ac4176b
PA
13351/* Implement the "catch assert" command. */
13352
13353static void
eb4c3f4a 13354catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13355 struct cmd_list_element *command)
13356{
a121b7c1 13357 const char *arg = arg_entry;
9ac4176b
PA
13358 struct gdbarch *gdbarch = get_current_arch ();
13359 int tempflag;
56ecd069 13360 std::string cond_string;
9ac4176b
PA
13361
13362 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13363
13364 if (!arg)
13365 arg = "";
56ecd069 13366 catch_ada_assert_command_split (arg, cond_string);
761269c8 13367 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
241db429 13368 "", cond_string,
349774ef
JB
13369 tempflag, 1 /* enabled */,
13370 from_tty);
9ac4176b 13371}
778865d3
JB
13372
13373/* Return non-zero if the symbol SYM is an Ada exception object. */
13374
13375static int
13376ada_is_exception_sym (struct symbol *sym)
13377{
a737d952 13378 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
778865d3
JB
13379
13380 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13381 && SYMBOL_CLASS (sym) != LOC_BLOCK
13382 && SYMBOL_CLASS (sym) != LOC_CONST
13383 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13384 && type_name != NULL && strcmp (type_name, "exception") == 0);
13385}
13386
13387/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13388 Ada exception object. This matches all exceptions except the ones
13389 defined by the Ada language. */
13390
13391static int
13392ada_is_non_standard_exception_sym (struct symbol *sym)
13393{
13394 int i;
13395
13396 if (!ada_is_exception_sym (sym))
13397 return 0;
13398
13399 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13400 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13401 return 0; /* A standard exception. */
13402
13403 /* Numeric_Error is also a standard exception, so exclude it.
13404 See the STANDARD_EXC description for more details as to why
13405 this exception is not listed in that array. */
13406 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13407 return 0;
13408
13409 return 1;
13410}
13411
ab816a27 13412/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13413 objects.
13414
13415 The comparison is determined first by exception name, and then
13416 by exception address. */
13417
ab816a27 13418bool
cc536b21 13419ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13420{
778865d3
JB
13421 int result;
13422
ab816a27
TT
13423 result = strcmp (name, other.name);
13424 if (result < 0)
13425 return true;
13426 if (result == 0 && addr < other.addr)
13427 return true;
13428 return false;
13429}
778865d3 13430
ab816a27 13431bool
cc536b21 13432ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13433{
13434 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13435}
13436
13437/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13438 routine, but keeping the first SKIP elements untouched.
13439
13440 All duplicates are also removed. */
13441
13442static void
ab816a27 13443sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13444 int skip)
13445{
ab816a27
TT
13446 std::sort (exceptions->begin () + skip, exceptions->end ());
13447 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13448 exceptions->end ());
778865d3
JB
13449}
13450
778865d3
JB
13451/* Add all exceptions defined by the Ada standard whose name match
13452 a regular expression.
13453
13454 If PREG is not NULL, then this regexp_t object is used to
13455 perform the symbol name matching. Otherwise, no name-based
13456 filtering is performed.
13457
13458 EXCEPTIONS is a vector of exceptions to which matching exceptions
13459 gets pushed. */
13460
13461static void
2d7cc5c7 13462ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13463 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13464{
13465 int i;
13466
13467 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13468 {
13469 if (preg == NULL
2d7cc5c7 13470 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13471 {
13472 struct bound_minimal_symbol msymbol
13473 = ada_lookup_simple_minsym (standard_exc[i]);
13474
13475 if (msymbol.minsym != NULL)
13476 {
13477 struct ada_exc_info info
77e371c0 13478 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13479
ab816a27 13480 exceptions->push_back (info);
778865d3
JB
13481 }
13482 }
13483 }
13484}
13485
13486/* Add all Ada exceptions defined locally and accessible from the given
13487 FRAME.
13488
13489 If PREG is not NULL, then this regexp_t object is used to
13490 perform the symbol name matching. Otherwise, no name-based
13491 filtering is performed.
13492
13493 EXCEPTIONS is a vector of exceptions to which matching exceptions
13494 gets pushed. */
13495
13496static void
2d7cc5c7
PA
13497ada_add_exceptions_from_frame (compiled_regex *preg,
13498 struct frame_info *frame,
ab816a27 13499 std::vector<ada_exc_info> *exceptions)
778865d3 13500{
3977b71f 13501 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13502
13503 while (block != 0)
13504 {
13505 struct block_iterator iter;
13506 struct symbol *sym;
13507
13508 ALL_BLOCK_SYMBOLS (block, iter, sym)
13509 {
13510 switch (SYMBOL_CLASS (sym))
13511 {
13512 case LOC_TYPEDEF:
13513 case LOC_BLOCK:
13514 case LOC_CONST:
13515 break;
13516 default:
13517 if (ada_is_exception_sym (sym))
13518 {
13519 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13520 SYMBOL_VALUE_ADDRESS (sym)};
13521
ab816a27 13522 exceptions->push_back (info);
778865d3
JB
13523 }
13524 }
13525 }
13526 if (BLOCK_FUNCTION (block) != NULL)
13527 break;
13528 block = BLOCK_SUPERBLOCK (block);
13529 }
13530}
13531
14bc53a8
PA
13532/* Return true if NAME matches PREG or if PREG is NULL. */
13533
13534static bool
2d7cc5c7 13535name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13536{
13537 return (preg == NULL
2d7cc5c7 13538 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13539}
13540
778865d3
JB
13541/* Add all exceptions defined globally whose name name match
13542 a regular expression, excluding standard exceptions.
13543
13544 The reason we exclude standard exceptions is that they need
13545 to be handled separately: Standard exceptions are defined inside
13546 a runtime unit which is normally not compiled with debugging info,
13547 and thus usually do not show up in our symbol search. However,
13548 if the unit was in fact built with debugging info, we need to
13549 exclude them because they would duplicate the entry we found
13550 during the special loop that specifically searches for those
13551 standard exceptions.
13552
13553 If PREG is not NULL, then this regexp_t object is used to
13554 perform the symbol name matching. Otherwise, no name-based
13555 filtering is performed.
13556
13557 EXCEPTIONS is a vector of exceptions to which matching exceptions
13558 gets pushed. */
13559
13560static void
2d7cc5c7 13561ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13562 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13563{
13564 struct objfile *objfile;
43f3e411 13565 struct compunit_symtab *s;
778865d3 13566
14bc53a8
PA
13567 /* In Ada, the symbol "search name" is a linkage name, whereas the
13568 regular expression used to do the matching refers to the natural
13569 name. So match against the decoded name. */
13570 expand_symtabs_matching (NULL,
b5ec771e 13571 lookup_name_info::match_any (),
14bc53a8
PA
13572 [&] (const char *search_name)
13573 {
13574 const char *decoded = ada_decode (search_name);
13575 return name_matches_regex (decoded, preg);
13576 },
13577 NULL,
13578 VARIABLES_DOMAIN);
778865d3 13579
43f3e411 13580 ALL_COMPUNITS (objfile, s)
778865d3 13581 {
43f3e411 13582 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13583 int i;
13584
13585 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13586 {
13587 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13588 struct block_iterator iter;
13589 struct symbol *sym;
13590
13591 ALL_BLOCK_SYMBOLS (b, iter, sym)
13592 if (ada_is_non_standard_exception_sym (sym)
14bc53a8 13593 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
778865d3
JB
13594 {
13595 struct ada_exc_info info
13596 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13597
ab816a27 13598 exceptions->push_back (info);
778865d3
JB
13599 }
13600 }
13601 }
13602}
13603
13604/* Implements ada_exceptions_list with the regular expression passed
13605 as a regex_t, rather than a string.
13606
13607 If not NULL, PREG is used to filter out exceptions whose names
13608 do not match. Otherwise, all exceptions are listed. */
13609
ab816a27 13610static std::vector<ada_exc_info>
2d7cc5c7 13611ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13612{
ab816a27 13613 std::vector<ada_exc_info> result;
778865d3
JB
13614 int prev_len;
13615
13616 /* First, list the known standard exceptions. These exceptions
13617 need to be handled separately, as they are usually defined in
13618 runtime units that have been compiled without debugging info. */
13619
13620 ada_add_standard_exceptions (preg, &result);
13621
13622 /* Next, find all exceptions whose scope is local and accessible
13623 from the currently selected frame. */
13624
13625 if (has_stack_frames ())
13626 {
ab816a27 13627 prev_len = result.size ();
778865d3
JB
13628 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13629 &result);
ab816a27 13630 if (result.size () > prev_len)
778865d3
JB
13631 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13632 }
13633
13634 /* Add all exceptions whose scope is global. */
13635
ab816a27 13636 prev_len = result.size ();
778865d3 13637 ada_add_global_exceptions (preg, &result);
ab816a27 13638 if (result.size () > prev_len)
778865d3
JB
13639 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13640
778865d3
JB
13641 return result;
13642}
13643
13644/* Return a vector of ada_exc_info.
13645
13646 If REGEXP is NULL, all exceptions are included in the result.
13647 Otherwise, it should contain a valid regular expression,
13648 and only the exceptions whose names match that regular expression
13649 are included in the result.
13650
13651 The exceptions are sorted in the following order:
13652 - Standard exceptions (defined by the Ada language), in
13653 alphabetical order;
13654 - Exceptions only visible from the current frame, in
13655 alphabetical order;
13656 - Exceptions whose scope is global, in alphabetical order. */
13657
ab816a27 13658std::vector<ada_exc_info>
778865d3
JB
13659ada_exceptions_list (const char *regexp)
13660{
2d7cc5c7
PA
13661 if (regexp == NULL)
13662 return ada_exceptions_list_1 (NULL);
778865d3 13663
2d7cc5c7
PA
13664 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13665 return ada_exceptions_list_1 (&reg);
778865d3
JB
13666}
13667
13668/* Implement the "info exceptions" command. */
13669
13670static void
1d12d88f 13671info_exceptions_command (const char *regexp, int from_tty)
778865d3 13672{
778865d3 13673 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13674
ab816a27 13675 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13676
13677 if (regexp != NULL)
13678 printf_filtered
13679 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13680 else
13681 printf_filtered (_("All defined Ada exceptions:\n"));
13682
ab816a27
TT
13683 for (const ada_exc_info &info : exceptions)
13684 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13685}
13686
4c4b4cd2
PH
13687 /* Operators */
13688/* Information about operators given special treatment in functions
13689 below. */
13690/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13691
13692#define ADA_OPERATORS \
13693 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13694 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13695 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13696 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13697 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13698 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13699 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13700 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13701 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13702 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13703 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13704 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13705 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13706 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13707 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13708 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13709 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13710 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13711 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13712
13713static void
554794dc
SDJ
13714ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13715 int *argsp)
4c4b4cd2
PH
13716{
13717 switch (exp->elts[pc - 1].opcode)
13718 {
76a01679 13719 default:
4c4b4cd2
PH
13720 operator_length_standard (exp, pc, oplenp, argsp);
13721 break;
13722
13723#define OP_DEFN(op, len, args, binop) \
13724 case op: *oplenp = len; *argsp = args; break;
13725 ADA_OPERATORS;
13726#undef OP_DEFN
52ce6436
PH
13727
13728 case OP_AGGREGATE:
13729 *oplenp = 3;
13730 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13731 break;
13732
13733 case OP_CHOICES:
13734 *oplenp = 3;
13735 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13736 break;
4c4b4cd2
PH
13737 }
13738}
13739
c0201579
JK
13740/* Implementation of the exp_descriptor method operator_check. */
13741
13742static int
13743ada_operator_check (struct expression *exp, int pos,
13744 int (*objfile_func) (struct objfile *objfile, void *data),
13745 void *data)
13746{
13747 const union exp_element *const elts = exp->elts;
13748 struct type *type = NULL;
13749
13750 switch (elts[pos].opcode)
13751 {
13752 case UNOP_IN_RANGE:
13753 case UNOP_QUAL:
13754 type = elts[pos + 1].type;
13755 break;
13756
13757 default:
13758 return operator_check_standard (exp, pos, objfile_func, data);
13759 }
13760
13761 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13762
13763 if (type && TYPE_OBJFILE (type)
13764 && (*objfile_func) (TYPE_OBJFILE (type), data))
13765 return 1;
13766
13767 return 0;
13768}
13769
a121b7c1 13770static const char *
4c4b4cd2
PH
13771ada_op_name (enum exp_opcode opcode)
13772{
13773 switch (opcode)
13774 {
76a01679 13775 default:
4c4b4cd2 13776 return op_name_standard (opcode);
52ce6436 13777
4c4b4cd2
PH
13778#define OP_DEFN(op, len, args, binop) case op: return #op;
13779 ADA_OPERATORS;
13780#undef OP_DEFN
52ce6436
PH
13781
13782 case OP_AGGREGATE:
13783 return "OP_AGGREGATE";
13784 case OP_CHOICES:
13785 return "OP_CHOICES";
13786 case OP_NAME:
13787 return "OP_NAME";
4c4b4cd2
PH
13788 }
13789}
13790
13791/* As for operator_length, but assumes PC is pointing at the first
13792 element of the operator, and gives meaningful results only for the
52ce6436 13793 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13794
13795static void
76a01679
JB
13796ada_forward_operator_length (struct expression *exp, int pc,
13797 int *oplenp, int *argsp)
4c4b4cd2 13798{
76a01679 13799 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13800 {
13801 default:
13802 *oplenp = *argsp = 0;
13803 break;
52ce6436 13804
4c4b4cd2
PH
13805#define OP_DEFN(op, len, args, binop) \
13806 case op: *oplenp = len; *argsp = args; break;
13807 ADA_OPERATORS;
13808#undef OP_DEFN
52ce6436
PH
13809
13810 case OP_AGGREGATE:
13811 *oplenp = 3;
13812 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13813 break;
13814
13815 case OP_CHOICES:
13816 *oplenp = 3;
13817 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13818 break;
13819
13820 case OP_STRING:
13821 case OP_NAME:
13822 {
13823 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13824
52ce6436
PH
13825 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13826 *argsp = 0;
13827 break;
13828 }
4c4b4cd2
PH
13829 }
13830}
13831
13832static int
13833ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13834{
13835 enum exp_opcode op = exp->elts[elt].opcode;
13836 int oplen, nargs;
13837 int pc = elt;
13838 int i;
76a01679 13839
4c4b4cd2
PH
13840 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13841
76a01679 13842 switch (op)
4c4b4cd2 13843 {
76a01679 13844 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13845 case OP_ATR_FIRST:
13846 case OP_ATR_LAST:
13847 case OP_ATR_LENGTH:
13848 case OP_ATR_IMAGE:
13849 case OP_ATR_MAX:
13850 case OP_ATR_MIN:
13851 case OP_ATR_MODULUS:
13852 case OP_ATR_POS:
13853 case OP_ATR_SIZE:
13854 case OP_ATR_TAG:
13855 case OP_ATR_VAL:
13856 break;
13857
13858 case UNOP_IN_RANGE:
13859 case UNOP_QUAL:
323e0a4a
AC
13860 /* XXX: gdb_sprint_host_address, type_sprint */
13861 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13862 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13863 fprintf_filtered (stream, " (");
13864 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13865 fprintf_filtered (stream, ")");
13866 break;
13867 case BINOP_IN_BOUNDS:
52ce6436
PH
13868 fprintf_filtered (stream, " (%d)",
13869 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13870 break;
13871 case TERNOP_IN_RANGE:
13872 break;
13873
52ce6436
PH
13874 case OP_AGGREGATE:
13875 case OP_OTHERS:
13876 case OP_DISCRETE_RANGE:
13877 case OP_POSITIONAL:
13878 case OP_CHOICES:
13879 break;
13880
13881 case OP_NAME:
13882 case OP_STRING:
13883 {
13884 char *name = &exp->elts[elt + 2].string;
13885 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13886
52ce6436
PH
13887 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13888 break;
13889 }
13890
4c4b4cd2
PH
13891 default:
13892 return dump_subexp_body_standard (exp, stream, elt);
13893 }
13894
13895 elt += oplen;
13896 for (i = 0; i < nargs; i += 1)
13897 elt = dump_subexp (exp, stream, elt);
13898
13899 return elt;
13900}
13901
13902/* The Ada extension of print_subexp (q.v.). */
13903
76a01679
JB
13904static void
13905ada_print_subexp (struct expression *exp, int *pos,
13906 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13907{
52ce6436 13908 int oplen, nargs, i;
4c4b4cd2
PH
13909 int pc = *pos;
13910 enum exp_opcode op = exp->elts[pc].opcode;
13911
13912 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13913
52ce6436 13914 *pos += oplen;
4c4b4cd2
PH
13915 switch (op)
13916 {
13917 default:
52ce6436 13918 *pos -= oplen;
4c4b4cd2
PH
13919 print_subexp_standard (exp, pos, stream, prec);
13920 return;
13921
13922 case OP_VAR_VALUE:
4c4b4cd2
PH
13923 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13924 return;
13925
13926 case BINOP_IN_BOUNDS:
323e0a4a 13927 /* XXX: sprint_subexp */
4c4b4cd2 13928 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13929 fputs_filtered (" in ", stream);
4c4b4cd2 13930 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13931 fputs_filtered ("'range", stream);
4c4b4cd2 13932 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13933 fprintf_filtered (stream, "(%ld)",
13934 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13935 return;
13936
13937 case TERNOP_IN_RANGE:
4c4b4cd2 13938 if (prec >= PREC_EQUAL)
76a01679 13939 fputs_filtered ("(", stream);
323e0a4a 13940 /* XXX: sprint_subexp */
4c4b4cd2 13941 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13942 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13943 print_subexp (exp, pos, stream, PREC_EQUAL);
13944 fputs_filtered (" .. ", stream);
13945 print_subexp (exp, pos, stream, PREC_EQUAL);
13946 if (prec >= PREC_EQUAL)
76a01679
JB
13947 fputs_filtered (")", stream);
13948 return;
4c4b4cd2
PH
13949
13950 case OP_ATR_FIRST:
13951 case OP_ATR_LAST:
13952 case OP_ATR_LENGTH:
13953 case OP_ATR_IMAGE:
13954 case OP_ATR_MAX:
13955 case OP_ATR_MIN:
13956 case OP_ATR_MODULUS:
13957 case OP_ATR_POS:
13958 case OP_ATR_SIZE:
13959 case OP_ATR_TAG:
13960 case OP_ATR_VAL:
4c4b4cd2 13961 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13962 {
13963 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13964 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13965 &type_print_raw_options);
76a01679
JB
13966 *pos += 3;
13967 }
4c4b4cd2 13968 else
76a01679 13969 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13970 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13971 if (nargs > 1)
76a01679
JB
13972 {
13973 int tem;
5b4ee69b 13974
76a01679
JB
13975 for (tem = 1; tem < nargs; tem += 1)
13976 {
13977 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13978 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13979 }
13980 fputs_filtered (")", stream);
13981 }
4c4b4cd2 13982 return;
14f9c5c9 13983
4c4b4cd2 13984 case UNOP_QUAL:
4c4b4cd2
PH
13985 type_print (exp->elts[pc + 1].type, "", stream, 0);
13986 fputs_filtered ("'(", stream);
13987 print_subexp (exp, pos, stream, PREC_PREFIX);
13988 fputs_filtered (")", stream);
13989 return;
14f9c5c9 13990
4c4b4cd2 13991 case UNOP_IN_RANGE:
323e0a4a 13992 /* XXX: sprint_subexp */
4c4b4cd2 13993 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13994 fputs_filtered (" in ", stream);
79d43c61
TT
13995 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13996 &type_print_raw_options);
4c4b4cd2 13997 return;
52ce6436
PH
13998
13999 case OP_DISCRETE_RANGE:
14000 print_subexp (exp, pos, stream, PREC_SUFFIX);
14001 fputs_filtered ("..", stream);
14002 print_subexp (exp, pos, stream, PREC_SUFFIX);
14003 return;
14004
14005 case OP_OTHERS:
14006 fputs_filtered ("others => ", stream);
14007 print_subexp (exp, pos, stream, PREC_SUFFIX);
14008 return;
14009
14010 case OP_CHOICES:
14011 for (i = 0; i < nargs-1; i += 1)
14012 {
14013 if (i > 0)
14014 fputs_filtered ("|", stream);
14015 print_subexp (exp, pos, stream, PREC_SUFFIX);
14016 }
14017 fputs_filtered (" => ", stream);
14018 print_subexp (exp, pos, stream, PREC_SUFFIX);
14019 return;
14020
14021 case OP_POSITIONAL:
14022 print_subexp (exp, pos, stream, PREC_SUFFIX);
14023 return;
14024
14025 case OP_AGGREGATE:
14026 fputs_filtered ("(", stream);
14027 for (i = 0; i < nargs; i += 1)
14028 {
14029 if (i > 0)
14030 fputs_filtered (", ", stream);
14031 print_subexp (exp, pos, stream, PREC_SUFFIX);
14032 }
14033 fputs_filtered (")", stream);
14034 return;
4c4b4cd2
PH
14035 }
14036}
14f9c5c9
AS
14037
14038/* Table mapping opcodes into strings for printing operators
14039 and precedences of the operators. */
14040
d2e4a39e
AS
14041static const struct op_print ada_op_print_tab[] = {
14042 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14043 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14044 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14045 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14046 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14047 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14048 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14049 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14050 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14051 {">=", BINOP_GEQ, PREC_ORDER, 0},
14052 {">", BINOP_GTR, PREC_ORDER, 0},
14053 {"<", BINOP_LESS, PREC_ORDER, 0},
14054 {">>", BINOP_RSH, PREC_SHIFT, 0},
14055 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14056 {"+", BINOP_ADD, PREC_ADD, 0},
14057 {"-", BINOP_SUB, PREC_ADD, 0},
14058 {"&", BINOP_CONCAT, PREC_ADD, 0},
14059 {"*", BINOP_MUL, PREC_MUL, 0},
14060 {"/", BINOP_DIV, PREC_MUL, 0},
14061 {"rem", BINOP_REM, PREC_MUL, 0},
14062 {"mod", BINOP_MOD, PREC_MUL, 0},
14063 {"**", BINOP_EXP, PREC_REPEAT, 0},
14064 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14065 {"-", UNOP_NEG, PREC_PREFIX, 0},
14066 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14067 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14068 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14069 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
14070 {".all", UNOP_IND, PREC_SUFFIX, 1},
14071 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14072 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 14073 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
14074};
14075\f
72d5681a
PH
14076enum ada_primitive_types {
14077 ada_primitive_type_int,
14078 ada_primitive_type_long,
14079 ada_primitive_type_short,
14080 ada_primitive_type_char,
14081 ada_primitive_type_float,
14082 ada_primitive_type_double,
14083 ada_primitive_type_void,
14084 ada_primitive_type_long_long,
14085 ada_primitive_type_long_double,
14086 ada_primitive_type_natural,
14087 ada_primitive_type_positive,
14088 ada_primitive_type_system_address,
08f49010 14089 ada_primitive_type_storage_offset,
72d5681a
PH
14090 nr_ada_primitive_types
14091};
6c038f32
PH
14092
14093static void
d4a9a881 14094ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
14095 struct language_arch_info *lai)
14096{
d4a9a881 14097 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 14098
72d5681a 14099 lai->primitive_type_vector
d4a9a881 14100 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 14101 struct type *);
e9bb382b
UW
14102
14103 lai->primitive_type_vector [ada_primitive_type_int]
14104 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14105 0, "integer");
14106 lai->primitive_type_vector [ada_primitive_type_long]
14107 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14108 0, "long_integer");
14109 lai->primitive_type_vector [ada_primitive_type_short]
14110 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14111 0, "short_integer");
14112 lai->string_char_type
14113 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 14114 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
14115 lai->primitive_type_vector [ada_primitive_type_float]
14116 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 14117 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
14118 lai->primitive_type_vector [ada_primitive_type_double]
14119 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14120 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14121 lai->primitive_type_vector [ada_primitive_type_long_long]
14122 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14123 0, "long_long_integer");
14124 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14125 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14126 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14127 lai->primitive_type_vector [ada_primitive_type_natural]
14128 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14129 0, "natural");
14130 lai->primitive_type_vector [ada_primitive_type_positive]
14131 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14132 0, "positive");
14133 lai->primitive_type_vector [ada_primitive_type_void]
14134 = builtin->builtin_void;
14135
14136 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14137 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14138 "void"));
72d5681a
PH
14139 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14140 = "system__address";
fbb06eb1 14141
08f49010
XR
14142 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14143 type. This is a signed integral type whose size is the same as
14144 the size of addresses. */
14145 {
14146 unsigned int addr_length = TYPE_LENGTH
14147 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14148
14149 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14150 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14151 "storage_offset");
14152 }
14153
47e729a8 14154 lai->bool_type_symbol = NULL;
fbb06eb1 14155 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14156}
6c038f32
PH
14157\f
14158 /* Language vector */
14159
14160/* Not really used, but needed in the ada_language_defn. */
14161
14162static void
6c7a06a3 14163emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14164{
6c7a06a3 14165 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14166}
14167
14168static int
410a0ff2 14169parse (struct parser_state *ps)
6c038f32
PH
14170{
14171 warnings_issued = 0;
410a0ff2 14172 return ada_parse (ps);
6c038f32
PH
14173}
14174
14175static const struct exp_descriptor ada_exp_descriptor = {
14176 ada_print_subexp,
14177 ada_operator_length,
c0201579 14178 ada_operator_check,
6c038f32
PH
14179 ada_op_name,
14180 ada_dump_subexp_body,
14181 ada_evaluate_subexp
14182};
14183
b5ec771e
PA
14184/* symbol_name_matcher_ftype adapter for wild_match. */
14185
14186static bool
14187do_wild_match (const char *symbol_search_name,
14188 const lookup_name_info &lookup_name,
a207cff2 14189 completion_match_result *comp_match_res)
b5ec771e
PA
14190{
14191 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14192}
14193
14194/* symbol_name_matcher_ftype adapter for full_match. */
14195
14196static bool
14197do_full_match (const char *symbol_search_name,
14198 const lookup_name_info &lookup_name,
a207cff2 14199 completion_match_result *comp_match_res)
b5ec771e
PA
14200{
14201 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14202}
14203
14204/* Build the Ada lookup name for LOOKUP_NAME. */
14205
14206ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14207{
14208 const std::string &user_name = lookup_name.name ();
14209
14210 if (user_name[0] == '<')
14211 {
14212 if (user_name.back () == '>')
14213 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14214 else
14215 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14216 m_encoded_p = true;
14217 m_verbatim_p = true;
14218 m_wild_match_p = false;
14219 m_standard_p = false;
14220 }
14221 else
14222 {
14223 m_verbatim_p = false;
14224
14225 m_encoded_p = user_name.find ("__") != std::string::npos;
14226
14227 if (!m_encoded_p)
14228 {
14229 const char *folded = ada_fold_name (user_name.c_str ());
14230 const char *encoded = ada_encode_1 (folded, false);
14231 if (encoded != NULL)
14232 m_encoded_name = encoded;
14233 else
14234 m_encoded_name = user_name;
14235 }
14236 else
14237 m_encoded_name = user_name;
14238
14239 /* Handle the 'package Standard' special case. See description
14240 of m_standard_p. */
14241 if (startswith (m_encoded_name.c_str (), "standard__"))
14242 {
14243 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14244 m_standard_p = true;
14245 }
14246 else
14247 m_standard_p = false;
74ccd7f5 14248
b5ec771e
PA
14249 /* If the name contains a ".", then the user is entering a fully
14250 qualified entity name, and the match must not be done in wild
14251 mode. Similarly, if the user wants to complete what looks
14252 like an encoded name, the match must not be done in wild
14253 mode. Also, in the standard__ special case always do
14254 non-wild matching. */
14255 m_wild_match_p
14256 = (lookup_name.match_type () != symbol_name_match_type::FULL
14257 && !m_encoded_p
14258 && !m_standard_p
14259 && user_name.find ('.') == std::string::npos);
14260 }
14261}
14262
14263/* symbol_name_matcher_ftype method for Ada. This only handles
14264 completion mode. */
14265
14266static bool
14267ada_symbol_name_matches (const char *symbol_search_name,
14268 const lookup_name_info &lookup_name,
a207cff2 14269 completion_match_result *comp_match_res)
74ccd7f5 14270{
b5ec771e
PA
14271 return lookup_name.ada ().matches (symbol_search_name,
14272 lookup_name.match_type (),
a207cff2 14273 comp_match_res);
b5ec771e
PA
14274}
14275
de63c46b
PA
14276/* A name matcher that matches the symbol name exactly, with
14277 strcmp. */
14278
14279static bool
14280literal_symbol_name_matcher (const char *symbol_search_name,
14281 const lookup_name_info &lookup_name,
14282 completion_match_result *comp_match_res)
14283{
14284 const std::string &name = lookup_name.name ();
14285
14286 int cmp = (lookup_name.completion_mode ()
14287 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14288 : strcmp (symbol_search_name, name.c_str ()));
14289 if (cmp == 0)
14290 {
14291 if (comp_match_res != NULL)
14292 comp_match_res->set_match (symbol_search_name);
14293 return true;
14294 }
14295 else
14296 return false;
14297}
14298
b5ec771e
PA
14299/* Implement the "la_get_symbol_name_matcher" language_defn method for
14300 Ada. */
14301
14302static symbol_name_matcher_ftype *
14303ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14304{
de63c46b
PA
14305 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14306 return literal_symbol_name_matcher;
14307
b5ec771e
PA
14308 if (lookup_name.completion_mode ())
14309 return ada_symbol_name_matches;
74ccd7f5 14310 else
b5ec771e
PA
14311 {
14312 if (lookup_name.ada ().wild_match_p ())
14313 return do_wild_match;
14314 else
14315 return do_full_match;
14316 }
74ccd7f5
JB
14317}
14318
a5ee536b
JB
14319/* Implement the "la_read_var_value" language_defn method for Ada. */
14320
14321static struct value *
63e43d3a
PMR
14322ada_read_var_value (struct symbol *var, const struct block *var_block,
14323 struct frame_info *frame)
a5ee536b 14324{
3977b71f 14325 const struct block *frame_block = NULL;
a5ee536b
JB
14326 struct symbol *renaming_sym = NULL;
14327
14328 /* The only case where default_read_var_value is not sufficient
14329 is when VAR is a renaming... */
14330 if (frame)
14331 frame_block = get_frame_block (frame, NULL);
14332 if (frame_block)
14333 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14334 if (renaming_sym != NULL)
14335 return ada_read_renaming_var_value (renaming_sym, frame_block);
14336
14337 /* This is a typical case where we expect the default_read_var_value
14338 function to work. */
63e43d3a 14339 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14340}
14341
56618e20
TT
14342static const char *ada_extensions[] =
14343{
14344 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14345};
14346
47e77640 14347extern const struct language_defn ada_language_defn = {
6c038f32 14348 "ada", /* Language name */
6abde28f 14349 "Ada",
6c038f32 14350 language_ada,
6c038f32 14351 range_check_off,
6c038f32
PH
14352 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14353 that's not quite what this means. */
6c038f32 14354 array_row_major,
9a044a89 14355 macro_expansion_no,
56618e20 14356 ada_extensions,
6c038f32
PH
14357 &ada_exp_descriptor,
14358 parse,
6c038f32
PH
14359 resolve,
14360 ada_printchar, /* Print a character constant */
14361 ada_printstr, /* Function to print string constant */
14362 emit_char, /* Function to print single char (not used) */
6c038f32 14363 ada_print_type, /* Print a type using appropriate syntax */
be942545 14364 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14365 ada_val_print, /* Print a value using appropriate syntax */
14366 ada_value_print, /* Print a top-level value */
a5ee536b 14367 ada_read_var_value, /* la_read_var_value */
6c038f32 14368 NULL, /* Language specific skip_trampoline */
2b2d9e11 14369 NULL, /* name_of_this */
59cc4834 14370 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14371 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14372 basic_lookup_transparent_type, /* lookup_transparent_type */
14373 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14374 ada_sniff_from_mangled_name,
0963b4bd
MS
14375 NULL, /* Language specific
14376 class_name_from_physname */
6c038f32
PH
14377 ada_op_print_tab, /* expression operators for printing */
14378 0, /* c-style arrays */
14379 1, /* String lower bound */
6c038f32 14380 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14381 ada_collect_symbol_completion_matches,
72d5681a 14382 ada_language_arch_info,
e79af960 14383 ada_print_array_index,
41f1b697 14384 default_pass_by_reference,
ae6a3a4c 14385 c_get_string,
43cc5389 14386 c_watch_location_expression,
b5ec771e 14387 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14388 ada_iterate_over_symbols,
5ffa0793 14389 default_search_name_hash,
a53b64ea 14390 &ada_varobj_ops,
bb2ec1b3
TT
14391 NULL,
14392 NULL,
6c038f32
PH
14393 LANG_MAGIC
14394};
14395
5bf03f13
JB
14396/* Command-list for the "set/show ada" prefix command. */
14397static struct cmd_list_element *set_ada_list;
14398static struct cmd_list_element *show_ada_list;
14399
14400/* Implement the "set ada" prefix command. */
14401
14402static void
981a3fb3 14403set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14404{
14405 printf_unfiltered (_(\
14406"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14407 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14408}
14409
14410/* Implement the "show ada" prefix command. */
14411
14412static void
981a3fb3 14413show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14414{
14415 cmd_show_list (show_ada_list, from_tty, "");
14416}
14417
2060206e
PA
14418static void
14419initialize_ada_catchpoint_ops (void)
14420{
14421 struct breakpoint_ops *ops;
14422
14423 initialize_breakpoint_ops ();
14424
14425 ops = &catch_exception_breakpoint_ops;
14426 *ops = bkpt_breakpoint_ops;
2060206e
PA
14427 ops->allocate_location = allocate_location_catch_exception;
14428 ops->re_set = re_set_catch_exception;
14429 ops->check_status = check_status_catch_exception;
14430 ops->print_it = print_it_catch_exception;
14431 ops->print_one = print_one_catch_exception;
14432 ops->print_mention = print_mention_catch_exception;
14433 ops->print_recreate = print_recreate_catch_exception;
14434
14435 ops = &catch_exception_unhandled_breakpoint_ops;
14436 *ops = bkpt_breakpoint_ops;
2060206e
PA
14437 ops->allocate_location = allocate_location_catch_exception_unhandled;
14438 ops->re_set = re_set_catch_exception_unhandled;
14439 ops->check_status = check_status_catch_exception_unhandled;
14440 ops->print_it = print_it_catch_exception_unhandled;
14441 ops->print_one = print_one_catch_exception_unhandled;
14442 ops->print_mention = print_mention_catch_exception_unhandled;
14443 ops->print_recreate = print_recreate_catch_exception_unhandled;
14444
14445 ops = &catch_assert_breakpoint_ops;
14446 *ops = bkpt_breakpoint_ops;
2060206e
PA
14447 ops->allocate_location = allocate_location_catch_assert;
14448 ops->re_set = re_set_catch_assert;
14449 ops->check_status = check_status_catch_assert;
14450 ops->print_it = print_it_catch_assert;
14451 ops->print_one = print_one_catch_assert;
14452 ops->print_mention = print_mention_catch_assert;
14453 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14454
14455 ops = &catch_handlers_breakpoint_ops;
14456 *ops = bkpt_breakpoint_ops;
14457 ops->allocate_location = allocate_location_catch_handlers;
14458 ops->re_set = re_set_catch_handlers;
14459 ops->check_status = check_status_catch_handlers;
14460 ops->print_it = print_it_catch_handlers;
14461 ops->print_one = print_one_catch_handlers;
14462 ops->print_mention = print_mention_catch_handlers;
14463 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14464}
14465
3d9434b5
JB
14466/* This module's 'new_objfile' observer. */
14467
14468static void
14469ada_new_objfile_observer (struct objfile *objfile)
14470{
14471 ada_clear_symbol_cache ();
14472}
14473
14474/* This module's 'free_objfile' observer. */
14475
14476static void
14477ada_free_objfile_observer (struct objfile *objfile)
14478{
14479 ada_clear_symbol_cache ();
14480}
14481
d2e4a39e 14482void
6c038f32 14483_initialize_ada_language (void)
14f9c5c9 14484{
2060206e
PA
14485 initialize_ada_catchpoint_ops ();
14486
5bf03f13
JB
14487 add_prefix_cmd ("ada", no_class, set_ada_command,
14488 _("Prefix command for changing Ada-specfic settings"),
14489 &set_ada_list, "set ada ", 0, &setlist);
14490
14491 add_prefix_cmd ("ada", no_class, show_ada_command,
14492 _("Generic command for showing Ada-specific settings."),
14493 &show_ada_list, "show ada ", 0, &showlist);
14494
14495 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14496 &trust_pad_over_xvs, _("\
14497Enable or disable an optimization trusting PAD types over XVS types"), _("\
14498Show whether an optimization trusting PAD types over XVS types is activated"),
14499 _("\
14500This is related to the encoding used by the GNAT compiler. The debugger\n\
14501should normally trust the contents of PAD types, but certain older versions\n\
14502of GNAT have a bug that sometimes causes the information in the PAD type\n\
14503to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14504work around this bug. It is always safe to turn this option \"off\", but\n\
14505this incurs a slight performance penalty, so it is recommended to NOT change\n\
14506this option to \"off\" unless necessary."),
14507 NULL, NULL, &set_ada_list, &show_ada_list);
14508
d72413e6
PMR
14509 add_setshow_boolean_cmd ("print-signatures", class_vars,
14510 &print_signatures, _("\
14511Enable or disable the output of formal and return types for functions in the \
14512overloads selection menu"), _("\
14513Show whether the output of formal and return types for functions in the \
14514overloads selection menu is activated"),
14515 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14516
9ac4176b
PA
14517 add_catch_command ("exception", _("\
14518Catch Ada exceptions, when raised.\n\
14519With an argument, catch only exceptions with the given name."),
14520 catch_ada_exception_command,
14521 NULL,
14522 CATCH_PERMANENT,
14523 CATCH_TEMPORARY);
9f757bf7
XR
14524
14525 add_catch_command ("handlers", _("\
14526Catch Ada exceptions, when handled.\n\
14527With an argument, catch only exceptions with the given name."),
14528 catch_ada_handlers_command,
14529 NULL,
14530 CATCH_PERMANENT,
14531 CATCH_TEMPORARY);
9ac4176b
PA
14532 add_catch_command ("assert", _("\
14533Catch failed Ada assertions, when raised.\n\
14534With an argument, catch only exceptions with the given name."),
14535 catch_assert_command,
14536 NULL,
14537 CATCH_PERMANENT,
14538 CATCH_TEMPORARY);
14539
6c038f32 14540 varsize_limit = 65536;
3fcded8f
JB
14541 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14542 &varsize_limit, _("\
14543Set the maximum number of bytes allowed in a variable-size object."), _("\
14544Show the maximum number of bytes allowed in a variable-size object."), _("\
14545Attempts to access an object whose size is not a compile-time constant\n\
14546and exceeds this limit will cause an error."),
14547 NULL, NULL, &setlist, &showlist);
6c038f32 14548
778865d3
JB
14549 add_info ("exceptions", info_exceptions_command,
14550 _("\
14551List all Ada exception names.\n\
14552If a regular expression is passed as an argument, only those matching\n\
14553the regular expression are listed."));
14554
c6044dd1
JB
14555 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14556 _("Set Ada maintenance-related variables."),
14557 &maint_set_ada_cmdlist, "maintenance set ada ",
14558 0/*allow-unknown*/, &maintenance_set_cmdlist);
14559
14560 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14561 _("Show Ada maintenance-related variables"),
14562 &maint_show_ada_cmdlist, "maintenance show ada ",
14563 0/*allow-unknown*/, &maintenance_show_cmdlist);
14564
14565 add_setshow_boolean_cmd
14566 ("ignore-descriptive-types", class_maintenance,
14567 &ada_ignore_descriptive_types_p,
14568 _("Set whether descriptive types generated by GNAT should be ignored."),
14569 _("Show whether descriptive types generated by GNAT should be ignored."),
14570 _("\
14571When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14572DWARF attribute."),
14573 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14574
459a2e4c
TT
14575 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14576 NULL, xcalloc, xfree);
6b69afc4 14577
3d9434b5 14578 /* The ada-lang observers. */
76727919
TT
14579 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14580 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14581 gdb::observers::inferior_exit.attach (ada_inferior_exit);
ee01b665
JB
14582
14583 /* Setup various context-specific data. */
e802dbe0 14584 ada_inferior_data
8e260fc0 14585 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14586 ada_pspace_data_handle
14587 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14588}