]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Support parallel make check with GNU make 4.2+
[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
544/* Return a string starting with '<', followed by STR, and '>'.
545 The result is good until the next call. */
546
547static char *
548add_angle_brackets (const char *str)
549{
550 static char *result = NULL;
551
552 xfree (result);
88c15c34 553 result = xstrprintf ("<%s>", str);
41d27058
JB
554 return result;
555}
96d887e8 556
67cb5b2d 557static const char *
4c4b4cd2
PH
558ada_get_gdb_completer_word_break_characters (void)
559{
560 return ada_completer_word_break_characters;
561}
562
e79af960
JB
563/* Print an array element index using the Ada syntax. */
564
565static void
566ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 567 const struct value_print_options *options)
e79af960 568{
79a45b7d 569 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
570 fprintf_filtered (stream, " => ");
571}
572
f27cf670 573/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 574 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 575 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 576
f27cf670
AS
577void *
578grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 579{
d2e4a39e
AS
580 if (*size < min_size)
581 {
582 *size *= 2;
583 if (*size < min_size)
4c4b4cd2 584 *size = min_size;
f27cf670 585 vect = xrealloc (vect, *size * element_size);
d2e4a39e 586 }
f27cf670 587 return vect;
14f9c5c9
AS
588}
589
590/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 591 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
592
593static int
ebf56fd3 594field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
595{
596 int len = strlen (target);
5b4ee69b 597
d2e4a39e 598 return
4c4b4cd2
PH
599 (strncmp (field_name, target, len) == 0
600 && (field_name[len] == '\0'
61012eef 601 || (startswith (field_name + len, "___")
76a01679
JB
602 && strcmp (field_name + strlen (field_name) - 6,
603 "___XVN") != 0)));
14f9c5c9
AS
604}
605
606
872c8b51
JB
607/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
608 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
609 and return its index. This function also handles fields whose name
610 have ___ suffixes because the compiler sometimes alters their name
611 by adding such a suffix to represent fields with certain constraints.
612 If the field could not be found, return a negative number if
613 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
614
615int
616ada_get_field_index (const struct type *type, const char *field_name,
617 int maybe_missing)
618{
619 int fieldno;
872c8b51
JB
620 struct type *struct_type = check_typedef ((struct type *) type);
621
622 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
623 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
624 return fieldno;
625
626 if (!maybe_missing)
323e0a4a 627 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 628 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
629
630 return -1;
631}
632
633/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
634
635int
d2e4a39e 636ada_name_prefix_len (const char *name)
14f9c5c9
AS
637{
638 if (name == NULL)
639 return 0;
d2e4a39e 640 else
14f9c5c9 641 {
d2e4a39e 642 const char *p = strstr (name, "___");
5b4ee69b 643
14f9c5c9 644 if (p == NULL)
4c4b4cd2 645 return strlen (name);
14f9c5c9 646 else
4c4b4cd2 647 return p - name;
14f9c5c9
AS
648 }
649}
650
4c4b4cd2
PH
651/* Return non-zero if SUFFIX is a suffix of STR.
652 Return zero if STR is null. */
653
14f9c5c9 654static int
d2e4a39e 655is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
656{
657 int len1, len2;
5b4ee69b 658
14f9c5c9
AS
659 if (str == NULL)
660 return 0;
661 len1 = strlen (str);
662 len2 = strlen (suffix);
4c4b4cd2 663 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
664}
665
4c4b4cd2
PH
666/* The contents of value VAL, treated as a value of type TYPE. The
667 result is an lval in memory if VAL is. */
14f9c5c9 668
d2e4a39e 669static struct value *
4c4b4cd2 670coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 671{
61ee279c 672 type = ada_check_typedef (type);
df407dfe 673 if (value_type (val) == type)
4c4b4cd2 674 return val;
d2e4a39e 675 else
14f9c5c9 676 {
4c4b4cd2
PH
677 struct value *result;
678
679 /* Make sure that the object size is not unreasonable before
680 trying to allocate some memory for it. */
c1b5a1a6 681 ada_ensure_varsize_limit (type);
4c4b4cd2 682
41e8491f
JK
683 if (value_lazy (val)
684 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
685 result = allocate_value_lazy (type);
686 else
687 {
688 result = allocate_value (type);
9a0dc9e3 689 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 690 }
74bcbdf3 691 set_value_component_location (result, val);
9bbda503
AC
692 set_value_bitsize (result, value_bitsize (val));
693 set_value_bitpos (result, value_bitpos (val));
42ae5230 694 set_value_address (result, value_address (val));
14f9c5c9
AS
695 return result;
696 }
697}
698
fc1a4b47
AC
699static const gdb_byte *
700cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
701{
702 if (valaddr == NULL)
703 return NULL;
704 else
705 return valaddr + offset;
706}
707
708static CORE_ADDR
ebf56fd3 709cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
710{
711 if (address == 0)
712 return 0;
d2e4a39e 713 else
14f9c5c9
AS
714 return address + offset;
715}
716
4c4b4cd2
PH
717/* Issue a warning (as for the definition of warning in utils.c, but
718 with exactly one argument rather than ...), unless the limit on the
719 number of warnings has passed during the evaluation of the current
720 expression. */
a2249542 721
77109804
AC
722/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
723 provided by "complaint". */
a0b31db1 724static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 725
14f9c5c9 726static void
a2249542 727lim_warning (const char *format, ...)
14f9c5c9 728{
a2249542 729 va_list args;
a2249542 730
5b4ee69b 731 va_start (args, format);
4c4b4cd2
PH
732 warnings_issued += 1;
733 if (warnings_issued <= warning_limit)
a2249542
MK
734 vwarning (format, args);
735
736 va_end (args);
4c4b4cd2
PH
737}
738
714e53ab
PH
739/* Issue an error if the size of an object of type T is unreasonable,
740 i.e. if it would be a bad idea to allocate a value of this type in
741 GDB. */
742
c1b5a1a6
JB
743void
744ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
745{
746 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 747 error (_("object size is larger than varsize-limit"));
714e53ab
PH
748}
749
0963b4bd 750/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 751static LONGEST
c3e5cd34 752max_of_size (int size)
4c4b4cd2 753{
76a01679 754 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 755
76a01679 756 return top_bit | (top_bit - 1);
4c4b4cd2
PH
757}
758
0963b4bd 759/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 760static LONGEST
c3e5cd34 761min_of_size (int size)
4c4b4cd2 762{
c3e5cd34 763 return -max_of_size (size) - 1;
4c4b4cd2
PH
764}
765
0963b4bd 766/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 767static ULONGEST
c3e5cd34 768umax_of_size (int size)
4c4b4cd2 769{
76a01679 770 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 771
76a01679 772 return top_bit | (top_bit - 1);
4c4b4cd2
PH
773}
774
0963b4bd 775/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
776static LONGEST
777max_of_type (struct type *t)
4c4b4cd2 778{
c3e5cd34
PH
779 if (TYPE_UNSIGNED (t))
780 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
781 else
782 return max_of_size (TYPE_LENGTH (t));
783}
784
0963b4bd 785/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
786static LONGEST
787min_of_type (struct type *t)
788{
789 if (TYPE_UNSIGNED (t))
790 return 0;
791 else
792 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
793}
794
795/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
796LONGEST
797ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 798{
c3345124 799 type = resolve_dynamic_type (type, NULL, 0);
76a01679 800 switch (TYPE_CODE (type))
4c4b4cd2
PH
801 {
802 case TYPE_CODE_RANGE:
690cc4eb 803 return TYPE_HIGH_BOUND (type);
4c4b4cd2 804 case TYPE_CODE_ENUM:
14e75d8e 805 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
806 case TYPE_CODE_BOOL:
807 return 1;
808 case TYPE_CODE_CHAR:
76a01679 809 case TYPE_CODE_INT:
690cc4eb 810 return max_of_type (type);
4c4b4cd2 811 default:
43bbcdc2 812 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
813 }
814}
815
14e75d8e 816/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
817LONGEST
818ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 819{
c3345124 820 type = resolve_dynamic_type (type, NULL, 0);
76a01679 821 switch (TYPE_CODE (type))
4c4b4cd2
PH
822 {
823 case TYPE_CODE_RANGE:
690cc4eb 824 return TYPE_LOW_BOUND (type);
4c4b4cd2 825 case TYPE_CODE_ENUM:
14e75d8e 826 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
827 case TYPE_CODE_BOOL:
828 return 0;
829 case TYPE_CODE_CHAR:
76a01679 830 case TYPE_CODE_INT:
690cc4eb 831 return min_of_type (type);
4c4b4cd2 832 default:
43bbcdc2 833 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
834 }
835}
836
837/* The identity on non-range types. For range types, the underlying
76a01679 838 non-range scalar type. */
4c4b4cd2
PH
839
840static struct type *
18af8284 841get_base_type (struct type *type)
4c4b4cd2
PH
842{
843 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
844 {
76a01679
JB
845 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
846 return type;
4c4b4cd2
PH
847 type = TYPE_TARGET_TYPE (type);
848 }
849 return type;
14f9c5c9 850}
41246937
JB
851
852/* Return a decoded version of the given VALUE. This means returning
853 a value whose type is obtained by applying all the GNAT-specific
854 encondings, making the resulting type a static but standard description
855 of the initial type. */
856
857struct value *
858ada_get_decoded_value (struct value *value)
859{
860 struct type *type = ada_check_typedef (value_type (value));
861
862 if (ada_is_array_descriptor_type (type)
863 || (ada_is_constrained_packed_array_type (type)
864 && TYPE_CODE (type) != TYPE_CODE_PTR))
865 {
866 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
867 value = ada_coerce_to_simple_array_ptr (value);
868 else
869 value = ada_coerce_to_simple_array (value);
870 }
871 else
872 value = ada_to_fixed_value (value);
873
874 return value;
875}
876
877/* Same as ada_get_decoded_value, but with the given TYPE.
878 Because there is no associated actual value for this type,
879 the resulting type might be a best-effort approximation in
880 the case of dynamic types. */
881
882struct type *
883ada_get_decoded_type (struct type *type)
884{
885 type = to_static_fixed_type (type);
886 if (ada_is_constrained_packed_array_type (type))
887 type = ada_coerce_to_simple_array_type (type);
888 return type;
889}
890
4c4b4cd2 891\f
76a01679 892
4c4b4cd2 893 /* Language Selection */
14f9c5c9
AS
894
895/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 896 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 897
14f9c5c9 898enum language
ccefe4c4 899ada_update_initial_language (enum language lang)
14f9c5c9 900{
d2e4a39e 901 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 902 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 903 return language_ada;
14f9c5c9
AS
904
905 return lang;
906}
96d887e8
PH
907
908/* If the main procedure is written in Ada, then return its name.
909 The result is good until the next call. Return NULL if the main
910 procedure doesn't appear to be in Ada. */
911
912char *
913ada_main_name (void)
914{
3b7344d5 915 struct bound_minimal_symbol msym;
e83e4e24 916 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 917
96d887e8
PH
918 /* For Ada, the name of the main procedure is stored in a specific
919 string constant, generated by the binder. Look for that symbol,
920 extract its address, and then read that string. If we didn't find
921 that string, then most probably the main procedure is not written
922 in Ada. */
923 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
924
3b7344d5 925 if (msym.minsym != NULL)
96d887e8 926 {
f9bc20b9
JB
927 CORE_ADDR main_program_name_addr;
928 int err_code;
929
77e371c0 930 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 931 if (main_program_name_addr == 0)
323e0a4a 932 error (_("Invalid address for Ada main program name."));
96d887e8 933
f9bc20b9
JB
934 target_read_string (main_program_name_addr, &main_program_name,
935 1024, &err_code);
936
937 if (err_code != 0)
938 return NULL;
e83e4e24 939 return main_program_name.get ();
96d887e8
PH
940 }
941
942 /* The main procedure doesn't seem to be in Ada. */
943 return NULL;
944}
14f9c5c9 945\f
4c4b4cd2 946 /* Symbols */
d2e4a39e 947
4c4b4cd2
PH
948/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
949 of NULLs. */
14f9c5c9 950
d2e4a39e
AS
951const struct ada_opname_map ada_opname_table[] = {
952 {"Oadd", "\"+\"", BINOP_ADD},
953 {"Osubtract", "\"-\"", BINOP_SUB},
954 {"Omultiply", "\"*\"", BINOP_MUL},
955 {"Odivide", "\"/\"", BINOP_DIV},
956 {"Omod", "\"mod\"", BINOP_MOD},
957 {"Orem", "\"rem\"", BINOP_REM},
958 {"Oexpon", "\"**\"", BINOP_EXP},
959 {"Olt", "\"<\"", BINOP_LESS},
960 {"Ole", "\"<=\"", BINOP_LEQ},
961 {"Ogt", "\">\"", BINOP_GTR},
962 {"Oge", "\">=\"", BINOP_GEQ},
963 {"Oeq", "\"=\"", BINOP_EQUAL},
964 {"One", "\"/=\"", BINOP_NOTEQUAL},
965 {"Oand", "\"and\"", BINOP_BITWISE_AND},
966 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
967 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
968 {"Oconcat", "\"&\"", BINOP_CONCAT},
969 {"Oabs", "\"abs\"", UNOP_ABS},
970 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
971 {"Oadd", "\"+\"", UNOP_PLUS},
972 {"Osubtract", "\"-\"", UNOP_NEG},
973 {NULL, NULL}
14f9c5c9
AS
974};
975
b5ec771e
PA
976/* The "encoded" form of DECODED, according to GNAT conventions. The
977 result is valid until the next call to ada_encode. If
978 THROW_ERRORS, throw an error if invalid operator name is found.
979 Otherwise, return NULL in that case. */
4c4b4cd2 980
b5ec771e
PA
981static char *
982ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 983{
4c4b4cd2
PH
984 static char *encoding_buffer = NULL;
985 static size_t encoding_buffer_size = 0;
d2e4a39e 986 const char *p;
14f9c5c9 987 int k;
d2e4a39e 988
4c4b4cd2 989 if (decoded == NULL)
14f9c5c9
AS
990 return NULL;
991
4c4b4cd2
PH
992 GROW_VECT (encoding_buffer, encoding_buffer_size,
993 2 * strlen (decoded) + 10);
14f9c5c9
AS
994
995 k = 0;
4c4b4cd2 996 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 997 {
cdc7bb92 998 if (*p == '.')
4c4b4cd2
PH
999 {
1000 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1001 k += 2;
1002 }
14f9c5c9 1003 else if (*p == '"')
4c4b4cd2
PH
1004 {
1005 const struct ada_opname_map *mapping;
1006
1007 for (mapping = ada_opname_table;
1265e4aa 1008 mapping->encoded != NULL
61012eef 1009 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1010 ;
1011 if (mapping->encoded == NULL)
b5ec771e
PA
1012 {
1013 if (throw_errors)
1014 error (_("invalid Ada operator name: %s"), p);
1015 else
1016 return NULL;
1017 }
4c4b4cd2
PH
1018 strcpy (encoding_buffer + k, mapping->encoded);
1019 k += strlen (mapping->encoded);
1020 break;
1021 }
d2e4a39e 1022 else
4c4b4cd2
PH
1023 {
1024 encoding_buffer[k] = *p;
1025 k += 1;
1026 }
14f9c5c9
AS
1027 }
1028
4c4b4cd2
PH
1029 encoding_buffer[k] = '\0';
1030 return encoding_buffer;
14f9c5c9
AS
1031}
1032
b5ec771e
PA
1033/* The "encoded" form of DECODED, according to GNAT conventions.
1034 The result is valid until the next call to ada_encode. */
1035
1036char *
1037ada_encode (const char *decoded)
1038{
1039 return ada_encode_1 (decoded, true);
1040}
1041
14f9c5c9 1042/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1043 quotes, unfolded, but with the quotes stripped away. Result good
1044 to next call. */
1045
d2e4a39e
AS
1046char *
1047ada_fold_name (const char *name)
14f9c5c9 1048{
d2e4a39e 1049 static char *fold_buffer = NULL;
14f9c5c9
AS
1050 static size_t fold_buffer_size = 0;
1051
1052 int len = strlen (name);
d2e4a39e 1053 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1054
1055 if (name[0] == '\'')
1056 {
d2e4a39e
AS
1057 strncpy (fold_buffer, name + 1, len - 2);
1058 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1059 }
1060 else
1061 {
1062 int i;
5b4ee69b 1063
14f9c5c9 1064 for (i = 0; i <= len; i += 1)
4c4b4cd2 1065 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1066 }
1067
1068 return fold_buffer;
1069}
1070
529cad9c
PH
1071/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1072
1073static int
1074is_lower_alphanum (const char c)
1075{
1076 return (isdigit (c) || (isalpha (c) && islower (c)));
1077}
1078
c90092fe
JB
1079/* ENCODED is the linkage name of a symbol and LEN contains its length.
1080 This function saves in LEN the length of that same symbol name but
1081 without either of these suffixes:
29480c32
JB
1082 . .{DIGIT}+
1083 . ${DIGIT}+
1084 . ___{DIGIT}+
1085 . __{DIGIT}+.
c90092fe 1086
29480c32
JB
1087 These are suffixes introduced by the compiler for entities such as
1088 nested subprogram for instance, in order to avoid name clashes.
1089 They do not serve any purpose for the debugger. */
1090
1091static void
1092ada_remove_trailing_digits (const char *encoded, int *len)
1093{
1094 if (*len > 1 && isdigit (encoded[*len - 1]))
1095 {
1096 int i = *len - 2;
5b4ee69b 1097
29480c32
JB
1098 while (i > 0 && isdigit (encoded[i]))
1099 i--;
1100 if (i >= 0 && encoded[i] == '.')
1101 *len = i;
1102 else if (i >= 0 && encoded[i] == '$')
1103 *len = i;
61012eef 1104 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1105 *len = i - 2;
61012eef 1106 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1107 *len = i - 1;
1108 }
1109}
1110
1111/* Remove the suffix introduced by the compiler for protected object
1112 subprograms. */
1113
1114static void
1115ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1116{
1117 /* Remove trailing N. */
1118
1119 /* Protected entry subprograms are broken into two
1120 separate subprograms: The first one is unprotected, and has
1121 a 'N' suffix; the second is the protected version, and has
0963b4bd 1122 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1123 the protection. Since the P subprograms are internally generated,
1124 we leave these names undecoded, giving the user a clue that this
1125 entity is internal. */
1126
1127 if (*len > 1
1128 && encoded[*len - 1] == 'N'
1129 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1130 *len = *len - 1;
1131}
1132
69fadcdf
JB
1133/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1134
1135static void
1136ada_remove_Xbn_suffix (const char *encoded, int *len)
1137{
1138 int i = *len - 1;
1139
1140 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1141 i--;
1142
1143 if (encoded[i] != 'X')
1144 return;
1145
1146 if (i == 0)
1147 return;
1148
1149 if (isalnum (encoded[i-1]))
1150 *len = i;
1151}
1152
29480c32
JB
1153/* If ENCODED follows the GNAT entity encoding conventions, then return
1154 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1155 replaced by ENCODED.
14f9c5c9 1156
4c4b4cd2 1157 The resulting string is valid until the next call of ada_decode.
29480c32 1158 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1159 is returned. */
1160
1161const char *
1162ada_decode (const char *encoded)
14f9c5c9
AS
1163{
1164 int i, j;
1165 int len0;
d2e4a39e 1166 const char *p;
4c4b4cd2 1167 char *decoded;
14f9c5c9 1168 int at_start_name;
4c4b4cd2
PH
1169 static char *decoding_buffer = NULL;
1170 static size_t decoding_buffer_size = 0;
d2e4a39e 1171
29480c32
JB
1172 /* The name of the Ada main procedure starts with "_ada_".
1173 This prefix is not part of the decoded name, so skip this part
1174 if we see this prefix. */
61012eef 1175 if (startswith (encoded, "_ada_"))
4c4b4cd2 1176 encoded += 5;
14f9c5c9 1177
29480c32
JB
1178 /* If the name starts with '_', then it is not a properly encoded
1179 name, so do not attempt to decode it. Similarly, if the name
1180 starts with '<', the name should not be decoded. */
4c4b4cd2 1181 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1182 goto Suppress;
1183
4c4b4cd2 1184 len0 = strlen (encoded);
4c4b4cd2 1185
29480c32
JB
1186 ada_remove_trailing_digits (encoded, &len0);
1187 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1188
4c4b4cd2
PH
1189 /* Remove the ___X.* suffix if present. Do not forget to verify that
1190 the suffix is located before the current "end" of ENCODED. We want
1191 to avoid re-matching parts of ENCODED that have previously been
1192 marked as discarded (by decrementing LEN0). */
1193 p = strstr (encoded, "___");
1194 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1195 {
1196 if (p[3] == 'X')
4c4b4cd2 1197 len0 = p - encoded;
14f9c5c9 1198 else
4c4b4cd2 1199 goto Suppress;
14f9c5c9 1200 }
4c4b4cd2 1201
29480c32
JB
1202 /* Remove any trailing TKB suffix. It tells us that this symbol
1203 is for the body of a task, but that information does not actually
1204 appear in the decoded name. */
1205
61012eef 1206 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1207 len0 -= 3;
76a01679 1208
a10967fa
JB
1209 /* Remove any trailing TB suffix. The TB suffix is slightly different
1210 from the TKB suffix because it is used for non-anonymous task
1211 bodies. */
1212
61012eef 1213 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1214 len0 -= 2;
1215
29480c32
JB
1216 /* Remove trailing "B" suffixes. */
1217 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1218
61012eef 1219 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1220 len0 -= 1;
1221
4c4b4cd2 1222 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1223
4c4b4cd2
PH
1224 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1225 decoded = decoding_buffer;
14f9c5c9 1226
29480c32
JB
1227 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1228
4c4b4cd2 1229 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1230 {
4c4b4cd2
PH
1231 i = len0 - 2;
1232 while ((i >= 0 && isdigit (encoded[i]))
1233 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1234 i -= 1;
1235 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1236 len0 = i - 1;
1237 else if (encoded[i] == '$')
1238 len0 = i;
d2e4a39e 1239 }
14f9c5c9 1240
29480c32
JB
1241 /* The first few characters that are not alphabetic are not part
1242 of any encoding we use, so we can copy them over verbatim. */
1243
4c4b4cd2
PH
1244 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1245 decoded[j] = encoded[i];
14f9c5c9
AS
1246
1247 at_start_name = 1;
1248 while (i < len0)
1249 {
29480c32 1250 /* Is this a symbol function? */
4c4b4cd2
PH
1251 if (at_start_name && encoded[i] == 'O')
1252 {
1253 int k;
5b4ee69b 1254
4c4b4cd2
PH
1255 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1256 {
1257 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1258 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1259 op_len - 1) == 0)
1260 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1261 {
1262 strcpy (decoded + j, ada_opname_table[k].decoded);
1263 at_start_name = 0;
1264 i += op_len;
1265 j += strlen (ada_opname_table[k].decoded);
1266 break;
1267 }
1268 }
1269 if (ada_opname_table[k].encoded != NULL)
1270 continue;
1271 }
14f9c5c9
AS
1272 at_start_name = 0;
1273
529cad9c
PH
1274 /* Replace "TK__" with "__", which will eventually be translated
1275 into "." (just below). */
1276
61012eef 1277 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1278 i += 2;
529cad9c 1279
29480c32
JB
1280 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1281 be translated into "." (just below). These are internal names
1282 generated for anonymous blocks inside which our symbol is nested. */
1283
1284 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1285 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1286 && isdigit (encoded [i+4]))
1287 {
1288 int k = i + 5;
1289
1290 while (k < len0 && isdigit (encoded[k]))
1291 k++; /* Skip any extra digit. */
1292
1293 /* Double-check that the "__B_{DIGITS}+" sequence we found
1294 is indeed followed by "__". */
1295 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1296 i = k;
1297 }
1298
529cad9c
PH
1299 /* Remove _E{DIGITS}+[sb] */
1300
1301 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1302 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1303 one implements the actual entry code, and has a suffix following
1304 the convention above; the second one implements the barrier and
1305 uses the same convention as above, except that the 'E' is replaced
1306 by a 'B'.
1307
1308 Just as above, we do not decode the name of barrier functions
1309 to give the user a clue that the code he is debugging has been
1310 internally generated. */
1311
1312 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1313 && isdigit (encoded[i+2]))
1314 {
1315 int k = i + 3;
1316
1317 while (k < len0 && isdigit (encoded[k]))
1318 k++;
1319
1320 if (k < len0
1321 && (encoded[k] == 'b' || encoded[k] == 's'))
1322 {
1323 k++;
1324 /* Just as an extra precaution, make sure that if this
1325 suffix is followed by anything else, it is a '_'.
1326 Otherwise, we matched this sequence by accident. */
1327 if (k == len0
1328 || (k < len0 && encoded[k] == '_'))
1329 i = k;
1330 }
1331 }
1332
1333 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1334 the GNAT front-end in protected object subprograms. */
1335
1336 if (i < len0 + 3
1337 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1338 {
1339 /* Backtrack a bit up until we reach either the begining of
1340 the encoded name, or "__". Make sure that we only find
1341 digits or lowercase characters. */
1342 const char *ptr = encoded + i - 1;
1343
1344 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1345 ptr--;
1346 if (ptr < encoded
1347 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1348 i++;
1349 }
1350
4c4b4cd2
PH
1351 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1352 {
29480c32
JB
1353 /* This is a X[bn]* sequence not separated from the previous
1354 part of the name with a non-alpha-numeric character (in other
1355 words, immediately following an alpha-numeric character), then
1356 verify that it is placed at the end of the encoded name. If
1357 not, then the encoding is not valid and we should abort the
1358 decoding. Otherwise, just skip it, it is used in body-nested
1359 package names. */
4c4b4cd2
PH
1360 do
1361 i += 1;
1362 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1363 if (i < len0)
1364 goto Suppress;
1365 }
cdc7bb92 1366 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1367 {
29480c32 1368 /* Replace '__' by '.'. */
4c4b4cd2
PH
1369 decoded[j] = '.';
1370 at_start_name = 1;
1371 i += 2;
1372 j += 1;
1373 }
14f9c5c9 1374 else
4c4b4cd2 1375 {
29480c32
JB
1376 /* It's a character part of the decoded name, so just copy it
1377 over. */
4c4b4cd2
PH
1378 decoded[j] = encoded[i];
1379 i += 1;
1380 j += 1;
1381 }
14f9c5c9 1382 }
4c4b4cd2 1383 decoded[j] = '\000';
14f9c5c9 1384
29480c32
JB
1385 /* Decoded names should never contain any uppercase character.
1386 Double-check this, and abort the decoding if we find one. */
1387
4c4b4cd2
PH
1388 for (i = 0; decoded[i] != '\0'; i += 1)
1389 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1390 goto Suppress;
1391
4c4b4cd2
PH
1392 if (strcmp (decoded, encoded) == 0)
1393 return encoded;
1394 else
1395 return decoded;
14f9c5c9
AS
1396
1397Suppress:
4c4b4cd2
PH
1398 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1399 decoded = decoding_buffer;
1400 if (encoded[0] == '<')
1401 strcpy (decoded, encoded);
14f9c5c9 1402 else
88c15c34 1403 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1404 return decoded;
1405
1406}
1407
1408/* Table for keeping permanent unique copies of decoded names. Once
1409 allocated, names in this table are never released. While this is a
1410 storage leak, it should not be significant unless there are massive
1411 changes in the set of decoded names in successive versions of a
1412 symbol table loaded during a single session. */
1413static struct htab *decoded_names_store;
1414
1415/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1416 in the language-specific part of GSYMBOL, if it has not been
1417 previously computed. Tries to save the decoded name in the same
1418 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1419 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1420 GSYMBOL).
4c4b4cd2
PH
1421 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1422 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1423 when a decoded name is cached in it. */
4c4b4cd2 1424
45e6c716 1425const char *
f85f34ed 1426ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1427{
f85f34ed
TT
1428 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1429 const char **resultp =
615b3f62 1430 &gsymbol->language_specific.demangled_name;
5b4ee69b 1431
f85f34ed 1432 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1433 {
1434 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1435 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1436
f85f34ed 1437 gsymbol->ada_mangled = 1;
5b4ee69b 1438
f85f34ed 1439 if (obstack != NULL)
224c3ddb
SM
1440 *resultp
1441 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1442 else
76a01679 1443 {
f85f34ed
TT
1444 /* Sometimes, we can't find a corresponding objfile, in
1445 which case, we put the result on the heap. Since we only
1446 decode when needed, we hope this usually does not cause a
1447 significant memory leak (FIXME). */
1448
76a01679
JB
1449 char **slot = (char **) htab_find_slot (decoded_names_store,
1450 decoded, INSERT);
5b4ee69b 1451
76a01679
JB
1452 if (*slot == NULL)
1453 *slot = xstrdup (decoded);
1454 *resultp = *slot;
1455 }
4c4b4cd2 1456 }
14f9c5c9 1457
4c4b4cd2
PH
1458 return *resultp;
1459}
76a01679 1460
2c0b251b 1461static char *
76a01679 1462ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1463{
1464 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1465}
1466
8b302db8
TT
1467/* Implement la_sniff_from_mangled_name for Ada. */
1468
1469static int
1470ada_sniff_from_mangled_name (const char *mangled, char **out)
1471{
1472 const char *demangled = ada_decode (mangled);
1473
1474 *out = NULL;
1475
1476 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1477 {
1478 /* Set the gsymbol language to Ada, but still return 0.
1479 Two reasons for that:
1480
1481 1. For Ada, we prefer computing the symbol's decoded name
1482 on the fly rather than pre-compute it, in order to save
1483 memory (Ada projects are typically very large).
1484
1485 2. There are some areas in the definition of the GNAT
1486 encoding where, with a bit of bad luck, we might be able
1487 to decode a non-Ada symbol, generating an incorrect
1488 demangled name (Eg: names ending with "TB" for instance
1489 are identified as task bodies and so stripped from
1490 the decoded name returned).
1491
1492 Returning 1, here, but not setting *DEMANGLED, helps us get a
1493 little bit of the best of both worlds. Because we're last,
1494 we should not affect any of the other languages that were
1495 able to demangle the symbol before us; we get to correctly
1496 tag Ada symbols as such; and even if we incorrectly tagged a
1497 non-Ada symbol, which should be rare, any routing through the
1498 Ada language should be transparent (Ada tries to behave much
1499 like C/C++ with non-Ada symbols). */
1500 return 1;
1501 }
1502
1503 return 0;
1504}
1505
14f9c5c9 1506\f
d2e4a39e 1507
4c4b4cd2 1508 /* Arrays */
14f9c5c9 1509
28c85d6c
JB
1510/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1511 generated by the GNAT compiler to describe the index type used
1512 for each dimension of an array, check whether it follows the latest
1513 known encoding. If not, fix it up to conform to the latest encoding.
1514 Otherwise, do nothing. This function also does nothing if
1515 INDEX_DESC_TYPE is NULL.
1516
1517 The GNAT encoding used to describle the array index type evolved a bit.
1518 Initially, the information would be provided through the name of each
1519 field of the structure type only, while the type of these fields was
1520 described as unspecified and irrelevant. The debugger was then expected
1521 to perform a global type lookup using the name of that field in order
1522 to get access to the full index type description. Because these global
1523 lookups can be very expensive, the encoding was later enhanced to make
1524 the global lookup unnecessary by defining the field type as being
1525 the full index type description.
1526
1527 The purpose of this routine is to allow us to support older versions
1528 of the compiler by detecting the use of the older encoding, and by
1529 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1530 we essentially replace each field's meaningless type by the associated
1531 index subtype). */
1532
1533void
1534ada_fixup_array_indexes_type (struct type *index_desc_type)
1535{
1536 int i;
1537
1538 if (index_desc_type == NULL)
1539 return;
1540 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1541
1542 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1543 to check one field only, no need to check them all). If not, return
1544 now.
1545
1546 If our INDEX_DESC_TYPE was generated using the older encoding,
1547 the field type should be a meaningless integer type whose name
1548 is not equal to the field name. */
1549 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1550 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1551 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1552 return;
1553
1554 /* Fixup each field of INDEX_DESC_TYPE. */
1555 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1556 {
0d5cff50 1557 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1558 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1559
1560 if (raw_type)
1561 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1562 }
1563}
1564
4c4b4cd2 1565/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1566
a121b7c1 1567static const char *bound_name[] = {
d2e4a39e 1568 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1569 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1570};
1571
1572/* Maximum number of array dimensions we are prepared to handle. */
1573
4c4b4cd2 1574#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1575
14f9c5c9 1576
4c4b4cd2
PH
1577/* The desc_* routines return primitive portions of array descriptors
1578 (fat pointers). */
14f9c5c9
AS
1579
1580/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1581 level of indirection, if needed. */
1582
d2e4a39e
AS
1583static struct type *
1584desc_base_type (struct type *type)
14f9c5c9
AS
1585{
1586 if (type == NULL)
1587 return NULL;
61ee279c 1588 type = ada_check_typedef (type);
720d1a40
JB
1589 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1590 type = ada_typedef_target_type (type);
1591
1265e4aa
JB
1592 if (type != NULL
1593 && (TYPE_CODE (type) == TYPE_CODE_PTR
1594 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1595 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1596 else
1597 return type;
1598}
1599
4c4b4cd2
PH
1600/* True iff TYPE indicates a "thin" array pointer type. */
1601
14f9c5c9 1602static int
d2e4a39e 1603is_thin_pntr (struct type *type)
14f9c5c9 1604{
d2e4a39e 1605 return
14f9c5c9
AS
1606 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1607 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1608}
1609
4c4b4cd2
PH
1610/* The descriptor type for thin pointer type TYPE. */
1611
d2e4a39e
AS
1612static struct type *
1613thin_descriptor_type (struct type *type)
14f9c5c9 1614{
d2e4a39e 1615 struct type *base_type = desc_base_type (type);
5b4ee69b 1616
14f9c5c9
AS
1617 if (base_type == NULL)
1618 return NULL;
1619 if (is_suffix (ada_type_name (base_type), "___XVE"))
1620 return base_type;
d2e4a39e 1621 else
14f9c5c9 1622 {
d2e4a39e 1623 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1624
14f9c5c9 1625 if (alt_type == NULL)
4c4b4cd2 1626 return base_type;
14f9c5c9 1627 else
4c4b4cd2 1628 return alt_type;
14f9c5c9
AS
1629 }
1630}
1631
4c4b4cd2
PH
1632/* A pointer to the array data for thin-pointer value VAL. */
1633
d2e4a39e
AS
1634static struct value *
1635thin_data_pntr (struct value *val)
14f9c5c9 1636{
828292f2 1637 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1638 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1639
556bdfd4
UW
1640 data_type = lookup_pointer_type (data_type);
1641
14f9c5c9 1642 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1643 return value_cast (data_type, value_copy (val));
d2e4a39e 1644 else
42ae5230 1645 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1646}
1647
4c4b4cd2
PH
1648/* True iff TYPE indicates a "thick" array pointer type. */
1649
14f9c5c9 1650static int
d2e4a39e 1651is_thick_pntr (struct type *type)
14f9c5c9
AS
1652{
1653 type = desc_base_type (type);
1654 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1655 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1656}
1657
4c4b4cd2
PH
1658/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1659 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1660
d2e4a39e
AS
1661static struct type *
1662desc_bounds_type (struct type *type)
14f9c5c9 1663{
d2e4a39e 1664 struct type *r;
14f9c5c9
AS
1665
1666 type = desc_base_type (type);
1667
1668 if (type == NULL)
1669 return NULL;
1670 else if (is_thin_pntr (type))
1671 {
1672 type = thin_descriptor_type (type);
1673 if (type == NULL)
4c4b4cd2 1674 return NULL;
14f9c5c9
AS
1675 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1676 if (r != NULL)
61ee279c 1677 return ada_check_typedef (r);
14f9c5c9
AS
1678 }
1679 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1680 {
1681 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1682 if (r != NULL)
61ee279c 1683 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1684 }
1685 return NULL;
1686}
1687
1688/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1689 one, a pointer to its bounds data. Otherwise NULL. */
1690
d2e4a39e
AS
1691static struct value *
1692desc_bounds (struct value *arr)
14f9c5c9 1693{
df407dfe 1694 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1695
d2e4a39e 1696 if (is_thin_pntr (type))
14f9c5c9 1697 {
d2e4a39e 1698 struct type *bounds_type =
4c4b4cd2 1699 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1700 LONGEST addr;
1701
4cdfadb1 1702 if (bounds_type == NULL)
323e0a4a 1703 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1704
1705 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1706 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1707 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1708 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1709 addr = value_as_long (arr);
d2e4a39e 1710 else
42ae5230 1711 addr = value_address (arr);
14f9c5c9 1712
d2e4a39e 1713 return
4c4b4cd2
PH
1714 value_from_longest (lookup_pointer_type (bounds_type),
1715 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1716 }
1717
1718 else if (is_thick_pntr (type))
05e522ef
JB
1719 {
1720 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1721 _("Bad GNAT array descriptor"));
1722 struct type *p_bounds_type = value_type (p_bounds);
1723
1724 if (p_bounds_type
1725 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1726 {
1727 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1728
1729 if (TYPE_STUB (target_type))
1730 p_bounds = value_cast (lookup_pointer_type
1731 (ada_check_typedef (target_type)),
1732 p_bounds);
1733 }
1734 else
1735 error (_("Bad GNAT array descriptor"));
1736
1737 return p_bounds;
1738 }
14f9c5c9
AS
1739 else
1740 return NULL;
1741}
1742
4c4b4cd2
PH
1743/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1744 position of the field containing the address of the bounds data. */
1745
14f9c5c9 1746static int
d2e4a39e 1747fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1748{
1749 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1750}
1751
1752/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1753 size of the field containing the address of the bounds data. */
1754
14f9c5c9 1755static int
d2e4a39e 1756fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1757{
1758 type = desc_base_type (type);
1759
d2e4a39e 1760 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1761 return TYPE_FIELD_BITSIZE (type, 1);
1762 else
61ee279c 1763 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1764}
1765
4c4b4cd2 1766/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1767 pointer to one, the type of its array data (a array-with-no-bounds type);
1768 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1769 data. */
4c4b4cd2 1770
d2e4a39e 1771static struct type *
556bdfd4 1772desc_data_target_type (struct type *type)
14f9c5c9
AS
1773{
1774 type = desc_base_type (type);
1775
4c4b4cd2 1776 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1777 if (is_thin_pntr (type))
556bdfd4 1778 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1779 else if (is_thick_pntr (type))
556bdfd4
UW
1780 {
1781 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1782
1783 if (data_type
1784 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1785 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1786 }
1787
1788 return NULL;
14f9c5c9
AS
1789}
1790
1791/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1792 its array data. */
4c4b4cd2 1793
d2e4a39e
AS
1794static struct value *
1795desc_data (struct value *arr)
14f9c5c9 1796{
df407dfe 1797 struct type *type = value_type (arr);
5b4ee69b 1798
14f9c5c9
AS
1799 if (is_thin_pntr (type))
1800 return thin_data_pntr (arr);
1801 else if (is_thick_pntr (type))
d2e4a39e 1802 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1803 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1804 else
1805 return NULL;
1806}
1807
1808
1809/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1810 position of the field containing the address of the data. */
1811
14f9c5c9 1812static int
d2e4a39e 1813fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1814{
1815 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1816}
1817
1818/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1819 size of the field containing the address of the data. */
1820
14f9c5c9 1821static int
d2e4a39e 1822fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1823{
1824 type = desc_base_type (type);
1825
1826 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1827 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1828 else
14f9c5c9
AS
1829 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1830}
1831
4c4b4cd2 1832/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1833 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1834 bound, if WHICH is 1. The first bound is I=1. */
1835
d2e4a39e
AS
1836static struct value *
1837desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1838{
d2e4a39e 1839 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1840 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1841}
1842
1843/* If BOUNDS is an array-bounds structure type, return the bit position
1844 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1845 bound, if WHICH is 1. The first bound is I=1. */
1846
14f9c5c9 1847static int
d2e4a39e 1848desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1849{
d2e4a39e 1850 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1851}
1852
1853/* If BOUNDS is an array-bounds structure type, return the bit field size
1854 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1855 bound, if WHICH is 1. The first bound is I=1. */
1856
76a01679 1857static int
d2e4a39e 1858desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1859{
1860 type = desc_base_type (type);
1861
d2e4a39e
AS
1862 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1863 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1864 else
1865 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1866}
1867
1868/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1869 Ith bound (numbering from 1). Otherwise, NULL. */
1870
d2e4a39e
AS
1871static struct type *
1872desc_index_type (struct type *type, int i)
14f9c5c9
AS
1873{
1874 type = desc_base_type (type);
1875
1876 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1877 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1878 else
14f9c5c9
AS
1879 return NULL;
1880}
1881
4c4b4cd2
PH
1882/* The number of index positions in the array-bounds type TYPE.
1883 Return 0 if TYPE is NULL. */
1884
14f9c5c9 1885static int
d2e4a39e 1886desc_arity (struct type *type)
14f9c5c9
AS
1887{
1888 type = desc_base_type (type);
1889
1890 if (type != NULL)
1891 return TYPE_NFIELDS (type) / 2;
1892 return 0;
1893}
1894
4c4b4cd2
PH
1895/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1896 an array descriptor type (representing an unconstrained array
1897 type). */
1898
76a01679
JB
1899static int
1900ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1901{
1902 if (type == NULL)
1903 return 0;
61ee279c 1904 type = ada_check_typedef (type);
4c4b4cd2 1905 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1906 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1907}
1908
52ce6436 1909/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1910 * to one. */
52ce6436 1911
2c0b251b 1912static int
52ce6436
PH
1913ada_is_array_type (struct type *type)
1914{
1915 while (type != NULL
1916 && (TYPE_CODE (type) == TYPE_CODE_PTR
1917 || TYPE_CODE (type) == TYPE_CODE_REF))
1918 type = TYPE_TARGET_TYPE (type);
1919 return ada_is_direct_array_type (type);
1920}
1921
4c4b4cd2 1922/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1923
14f9c5c9 1924int
4c4b4cd2 1925ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1926{
1927 if (type == NULL)
1928 return 0;
61ee279c 1929 type = ada_check_typedef (type);
14f9c5c9 1930 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1931 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1932 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1933 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1934}
1935
4c4b4cd2
PH
1936/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1937
14f9c5c9 1938int
4c4b4cd2 1939ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1940{
556bdfd4 1941 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1942
1943 if (type == NULL)
1944 return 0;
61ee279c 1945 type = ada_check_typedef (type);
556bdfd4
UW
1946 return (data_type != NULL
1947 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1948 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1949}
1950
1951/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1952 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1953 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1954 is still needed. */
1955
14f9c5c9 1956int
ebf56fd3 1957ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1958{
d2e4a39e 1959 return
14f9c5c9
AS
1960 type != NULL
1961 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1962 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1963 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1964 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1965}
1966
1967
4c4b4cd2 1968/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1969 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1970 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1971 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1972 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1973 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1974 a descriptor. */
d2e4a39e
AS
1975struct type *
1976ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1977{
ad82864c
JB
1978 if (ada_is_constrained_packed_array_type (value_type (arr)))
1979 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1980
df407dfe
AC
1981 if (!ada_is_array_descriptor_type (value_type (arr)))
1982 return value_type (arr);
d2e4a39e
AS
1983
1984 if (!bounds)
ad82864c
JB
1985 {
1986 struct type *array_type =
1987 ada_check_typedef (desc_data_target_type (value_type (arr)));
1988
1989 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1990 TYPE_FIELD_BITSIZE (array_type, 0) =
1991 decode_packed_array_bitsize (value_type (arr));
1992
1993 return array_type;
1994 }
14f9c5c9
AS
1995 else
1996 {
d2e4a39e 1997 struct type *elt_type;
14f9c5c9 1998 int arity;
d2e4a39e 1999 struct value *descriptor;
14f9c5c9 2000
df407dfe
AC
2001 elt_type = ada_array_element_type (value_type (arr), -1);
2002 arity = ada_array_arity (value_type (arr));
14f9c5c9 2003
d2e4a39e 2004 if (elt_type == NULL || arity == 0)
df407dfe 2005 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2006
2007 descriptor = desc_bounds (arr);
d2e4a39e 2008 if (value_as_long (descriptor) == 0)
4c4b4cd2 2009 return NULL;
d2e4a39e 2010 while (arity > 0)
4c4b4cd2 2011 {
e9bb382b
UW
2012 struct type *range_type = alloc_type_copy (value_type (arr));
2013 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2014 struct value *low = desc_one_bound (descriptor, arity, 0);
2015 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2016
5b4ee69b 2017 arity -= 1;
0c9c3474
SA
2018 create_static_range_type (range_type, value_type (low),
2019 longest_to_int (value_as_long (low)),
2020 longest_to_int (value_as_long (high)));
4c4b4cd2 2021 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2022
2023 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2024 {
2025 /* We need to store the element packed bitsize, as well as
2026 recompute the array size, because it was previously
2027 computed based on the unpacked element size. */
2028 LONGEST lo = value_as_long (low);
2029 LONGEST hi = value_as_long (high);
2030
2031 TYPE_FIELD_BITSIZE (elt_type, 0) =
2032 decode_packed_array_bitsize (value_type (arr));
2033 /* If the array has no element, then the size is already
2034 zero, and does not need to be recomputed. */
2035 if (lo < hi)
2036 {
2037 int array_bitsize =
2038 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2039
2040 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2041 }
2042 }
4c4b4cd2 2043 }
14f9c5c9
AS
2044
2045 return lookup_pointer_type (elt_type);
2046 }
2047}
2048
2049/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2050 Otherwise, returns either a standard GDB array with bounds set
2051 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2052 GDB array. Returns NULL if ARR is a null fat pointer. */
2053
d2e4a39e
AS
2054struct value *
2055ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2056{
df407dfe 2057 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2058 {
d2e4a39e 2059 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2060
14f9c5c9 2061 if (arrType == NULL)
4c4b4cd2 2062 return NULL;
14f9c5c9
AS
2063 return value_cast (arrType, value_copy (desc_data (arr)));
2064 }
ad82864c
JB
2065 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2066 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2067 else
2068 return arr;
2069}
2070
2071/* If ARR does not represent an array, returns ARR unchanged.
2072 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2073 be ARR itself if it already is in the proper form). */
2074
720d1a40 2075struct value *
d2e4a39e 2076ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2077{
df407dfe 2078 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2079 {
d2e4a39e 2080 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2081
14f9c5c9 2082 if (arrVal == NULL)
323e0a4a 2083 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2084 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2085 return value_ind (arrVal);
2086 }
ad82864c
JB
2087 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2088 return decode_constrained_packed_array (arr);
d2e4a39e 2089 else
14f9c5c9
AS
2090 return arr;
2091}
2092
2093/* If TYPE represents a GNAT array type, return it translated to an
2094 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2095 packing). For other types, is the identity. */
2096
d2e4a39e
AS
2097struct type *
2098ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2099{
ad82864c
JB
2100 if (ada_is_constrained_packed_array_type (type))
2101 return decode_constrained_packed_array_type (type);
17280b9f
UW
2102
2103 if (ada_is_array_descriptor_type (type))
556bdfd4 2104 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2105
2106 return type;
14f9c5c9
AS
2107}
2108
4c4b4cd2
PH
2109/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2110
ad82864c
JB
2111static int
2112ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2113{
2114 if (type == NULL)
2115 return 0;
4c4b4cd2 2116 type = desc_base_type (type);
61ee279c 2117 type = ada_check_typedef (type);
d2e4a39e 2118 return
14f9c5c9
AS
2119 ada_type_name (type) != NULL
2120 && strstr (ada_type_name (type), "___XP") != NULL;
2121}
2122
ad82864c
JB
2123/* Non-zero iff TYPE represents a standard GNAT constrained
2124 packed-array type. */
2125
2126int
2127ada_is_constrained_packed_array_type (struct type *type)
2128{
2129 return ada_is_packed_array_type (type)
2130 && !ada_is_array_descriptor_type (type);
2131}
2132
2133/* Non-zero iff TYPE represents an array descriptor for a
2134 unconstrained packed-array type. */
2135
2136static int
2137ada_is_unconstrained_packed_array_type (struct type *type)
2138{
2139 return ada_is_packed_array_type (type)
2140 && ada_is_array_descriptor_type (type);
2141}
2142
2143/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2144 return the size of its elements in bits. */
2145
2146static long
2147decode_packed_array_bitsize (struct type *type)
2148{
0d5cff50
DE
2149 const char *raw_name;
2150 const char *tail;
ad82864c
JB
2151 long bits;
2152
720d1a40
JB
2153 /* Access to arrays implemented as fat pointers are encoded as a typedef
2154 of the fat pointer type. We need the name of the fat pointer type
2155 to do the decoding, so strip the typedef layer. */
2156 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2157 type = ada_typedef_target_type (type);
2158
2159 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2160 if (!raw_name)
2161 raw_name = ada_type_name (desc_base_type (type));
2162
2163 if (!raw_name)
2164 return 0;
2165
2166 tail = strstr (raw_name, "___XP");
720d1a40 2167 gdb_assert (tail != NULL);
ad82864c
JB
2168
2169 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2170 {
2171 lim_warning
2172 (_("could not understand bit size information on packed array"));
2173 return 0;
2174 }
2175
2176 return bits;
2177}
2178
14f9c5c9
AS
2179/* Given that TYPE is a standard GDB array type with all bounds filled
2180 in, and that the element size of its ultimate scalar constituents
2181 (that is, either its elements, or, if it is an array of arrays, its
2182 elements' elements, etc.) is *ELT_BITS, return an identical type,
2183 but with the bit sizes of its elements (and those of any
2184 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2185 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2186 in bits.
2187
2188 Note that, for arrays whose index type has an XA encoding where
2189 a bound references a record discriminant, getting that discriminant,
2190 and therefore the actual value of that bound, is not possible
2191 because none of the given parameters gives us access to the record.
2192 This function assumes that it is OK in the context where it is being
2193 used to return an array whose bounds are still dynamic and where
2194 the length is arbitrary. */
4c4b4cd2 2195
d2e4a39e 2196static struct type *
ad82864c 2197constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2198{
d2e4a39e
AS
2199 struct type *new_elt_type;
2200 struct type *new_type;
99b1c762
JB
2201 struct type *index_type_desc;
2202 struct type *index_type;
14f9c5c9
AS
2203 LONGEST low_bound, high_bound;
2204
61ee279c 2205 type = ada_check_typedef (type);
14f9c5c9
AS
2206 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2207 return type;
2208
99b1c762
JB
2209 index_type_desc = ada_find_parallel_type (type, "___XA");
2210 if (index_type_desc)
2211 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2212 NULL);
2213 else
2214 index_type = TYPE_INDEX_TYPE (type);
2215
e9bb382b 2216 new_type = alloc_type_copy (type);
ad82864c
JB
2217 new_elt_type =
2218 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2219 elt_bits);
99b1c762 2220 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2221 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2222 TYPE_NAME (new_type) = ada_type_name (type);
2223
4a46959e
JB
2224 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2225 && is_dynamic_type (check_typedef (index_type)))
2226 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2227 low_bound = high_bound = 0;
2228 if (high_bound < low_bound)
2229 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2230 else
14f9c5c9
AS
2231 {
2232 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2233 TYPE_LENGTH (new_type) =
4c4b4cd2 2234 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2235 }
2236
876cecd0 2237 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2238 return new_type;
2239}
2240
ad82864c
JB
2241/* The array type encoded by TYPE, where
2242 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2243
d2e4a39e 2244static struct type *
ad82864c 2245decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2246{
0d5cff50 2247 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2248 char *name;
0d5cff50 2249 const char *tail;
d2e4a39e 2250 struct type *shadow_type;
14f9c5c9 2251 long bits;
14f9c5c9 2252
727e3d2e
JB
2253 if (!raw_name)
2254 raw_name = ada_type_name (desc_base_type (type));
2255
2256 if (!raw_name)
2257 return NULL;
2258
2259 name = (char *) alloca (strlen (raw_name) + 1);
2260 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2261 type = desc_base_type (type);
2262
14f9c5c9
AS
2263 memcpy (name, raw_name, tail - raw_name);
2264 name[tail - raw_name] = '\000';
2265
b4ba55a1
JB
2266 shadow_type = ada_find_parallel_type_with_name (type, name);
2267
2268 if (shadow_type == NULL)
14f9c5c9 2269 {
323e0a4a 2270 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2271 return NULL;
2272 }
f168693b 2273 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2274
2275 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2276 {
0963b4bd
MS
2277 lim_warning (_("could not understand bounds "
2278 "information on packed array"));
14f9c5c9
AS
2279 return NULL;
2280 }
d2e4a39e 2281
ad82864c
JB
2282 bits = decode_packed_array_bitsize (type);
2283 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2284}
2285
ad82864c
JB
2286/* Given that ARR is a struct value *indicating a GNAT constrained packed
2287 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2288 standard GDB array type except that the BITSIZEs of the array
2289 target types are set to the number of bits in each element, and the
4c4b4cd2 2290 type length is set appropriately. */
14f9c5c9 2291
d2e4a39e 2292static struct value *
ad82864c 2293decode_constrained_packed_array (struct value *arr)
14f9c5c9 2294{
4c4b4cd2 2295 struct type *type;
14f9c5c9 2296
11aa919a
PMR
2297 /* If our value is a pointer, then dereference it. Likewise if
2298 the value is a reference. Make sure that this operation does not
2299 cause the target type to be fixed, as this would indirectly cause
2300 this array to be decoded. The rest of the routine assumes that
2301 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2302 and "value_ind" routines to perform the dereferencing, as opposed
2303 to using "ada_coerce_ref" or "ada_value_ind". */
2304 arr = coerce_ref (arr);
828292f2 2305 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2306 arr = value_ind (arr);
4c4b4cd2 2307
ad82864c 2308 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2309 if (type == NULL)
2310 {
323e0a4a 2311 error (_("can't unpack array"));
14f9c5c9
AS
2312 return NULL;
2313 }
61ee279c 2314
50810684 2315 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2316 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2317 {
2318 /* This is a (right-justified) modular type representing a packed
2319 array with no wrapper. In order to interpret the value through
2320 the (left-justified) packed array type we just built, we must
2321 first left-justify it. */
2322 int bit_size, bit_pos;
2323 ULONGEST mod;
2324
df407dfe 2325 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2326 bit_size = 0;
2327 while (mod > 0)
2328 {
2329 bit_size += 1;
2330 mod >>= 1;
2331 }
df407dfe 2332 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2333 arr = ada_value_primitive_packed_val (arr, NULL,
2334 bit_pos / HOST_CHAR_BIT,
2335 bit_pos % HOST_CHAR_BIT,
2336 bit_size,
2337 type);
2338 }
2339
4c4b4cd2 2340 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2341}
2342
2343
2344/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2345 given in IND. ARR must be a simple array. */
14f9c5c9 2346
d2e4a39e
AS
2347static struct value *
2348value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2349{
2350 int i;
2351 int bits, elt_off, bit_off;
2352 long elt_total_bit_offset;
d2e4a39e
AS
2353 struct type *elt_type;
2354 struct value *v;
14f9c5c9
AS
2355
2356 bits = 0;
2357 elt_total_bit_offset = 0;
df407dfe 2358 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2359 for (i = 0; i < arity; i += 1)
14f9c5c9 2360 {
d2e4a39e 2361 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2362 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2363 error
0963b4bd
MS
2364 (_("attempt to do packed indexing of "
2365 "something other than a packed array"));
14f9c5c9 2366 else
4c4b4cd2
PH
2367 {
2368 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2369 LONGEST lowerbound, upperbound;
2370 LONGEST idx;
2371
2372 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2373 {
323e0a4a 2374 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2375 lowerbound = upperbound = 0;
2376 }
2377
3cb382c9 2378 idx = pos_atr (ind[i]);
4c4b4cd2 2379 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2380 lim_warning (_("packed array index %ld out of bounds"),
2381 (long) idx);
4c4b4cd2
PH
2382 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2383 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2384 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2385 }
14f9c5c9
AS
2386 }
2387 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2388 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2389
2390 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2391 bits, elt_type);
14f9c5c9
AS
2392 return v;
2393}
2394
4c4b4cd2 2395/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2396
2397static int
d2e4a39e 2398has_negatives (struct type *type)
14f9c5c9 2399{
d2e4a39e
AS
2400 switch (TYPE_CODE (type))
2401 {
2402 default:
2403 return 0;
2404 case TYPE_CODE_INT:
2405 return !TYPE_UNSIGNED (type);
2406 case TYPE_CODE_RANGE:
2407 return TYPE_LOW_BOUND (type) < 0;
2408 }
14f9c5c9 2409}
d2e4a39e 2410
f93fca70 2411/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2412 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2413 the unpacked buffer.
14f9c5c9 2414
5b639dea
JB
2415 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2416 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2417
f93fca70
JB
2418 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2419 zero otherwise.
14f9c5c9 2420
f93fca70 2421 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2422
f93fca70
JB
2423 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2424
2425static void
2426ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2427 gdb_byte *unpacked, int unpacked_len,
2428 int is_big_endian, int is_signed_type,
2429 int is_scalar)
2430{
a1c95e6b
JB
2431 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2432 int src_idx; /* Index into the source area */
2433 int src_bytes_left; /* Number of source bytes left to process. */
2434 int srcBitsLeft; /* Number of source bits left to move */
2435 int unusedLS; /* Number of bits in next significant
2436 byte of source that are unused */
2437
a1c95e6b
JB
2438 int unpacked_idx; /* Index into the unpacked buffer */
2439 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2440
4c4b4cd2 2441 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2442 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2443 unsigned char sign;
a1c95e6b 2444
4c4b4cd2
PH
2445 /* Transmit bytes from least to most significant; delta is the direction
2446 the indices move. */
f93fca70 2447 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2448
5b639dea
JB
2449 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2450 bits from SRC. .*/
2451 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2452 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2453 bit_size, unpacked_len);
2454
14f9c5c9 2455 srcBitsLeft = bit_size;
086ca51f 2456 src_bytes_left = src_len;
f93fca70 2457 unpacked_bytes_left = unpacked_len;
14f9c5c9 2458 sign = 0;
f93fca70
JB
2459
2460 if (is_big_endian)
14f9c5c9 2461 {
086ca51f 2462 src_idx = src_len - 1;
f93fca70
JB
2463 if (is_signed_type
2464 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2465 sign = ~0;
d2e4a39e
AS
2466
2467 unusedLS =
4c4b4cd2
PH
2468 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2469 % HOST_CHAR_BIT;
14f9c5c9 2470
f93fca70
JB
2471 if (is_scalar)
2472 {
2473 accumSize = 0;
2474 unpacked_idx = unpacked_len - 1;
2475 }
2476 else
2477 {
4c4b4cd2
PH
2478 /* Non-scalar values must be aligned at a byte boundary... */
2479 accumSize =
2480 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2481 /* ... And are placed at the beginning (most-significant) bytes
2482 of the target. */
086ca51f
JB
2483 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2484 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2485 }
14f9c5c9 2486 }
d2e4a39e 2487 else
14f9c5c9
AS
2488 {
2489 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2490
086ca51f 2491 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2492 unusedLS = bit_offset;
2493 accumSize = 0;
2494
f93fca70 2495 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2496 sign = ~0;
14f9c5c9 2497 }
d2e4a39e 2498
14f9c5c9 2499 accum = 0;
086ca51f 2500 while (src_bytes_left > 0)
14f9c5c9
AS
2501 {
2502 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2503 part of the value. */
d2e4a39e 2504 unsigned int unusedMSMask =
4c4b4cd2
PH
2505 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2506 1;
2507 /* Sign-extend bits for this byte. */
14f9c5c9 2508 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2509
d2e4a39e 2510 accum |=
086ca51f 2511 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2512 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2513 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2514 {
db297a65 2515 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2516 accumSize -= HOST_CHAR_BIT;
2517 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2518 unpacked_bytes_left -= 1;
2519 unpacked_idx += delta;
4c4b4cd2 2520 }
14f9c5c9
AS
2521 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2522 unusedLS = 0;
086ca51f
JB
2523 src_bytes_left -= 1;
2524 src_idx += delta;
14f9c5c9 2525 }
086ca51f 2526 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2527 {
2528 accum |= sign << accumSize;
db297a65 2529 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2530 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2531 if (accumSize < 0)
2532 accumSize = 0;
14f9c5c9 2533 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2534 unpacked_bytes_left -= 1;
2535 unpacked_idx += delta;
14f9c5c9 2536 }
f93fca70
JB
2537}
2538
2539/* Create a new value of type TYPE from the contents of OBJ starting
2540 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2541 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2542 assigning through the result will set the field fetched from.
2543 VALADDR is ignored unless OBJ is NULL, in which case,
2544 VALADDR+OFFSET must address the start of storage containing the
2545 packed value. The value returned in this case is never an lval.
2546 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2547
2548struct value *
2549ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2550 long offset, int bit_offset, int bit_size,
2551 struct type *type)
2552{
2553 struct value *v;
bfb1c796 2554 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2555 gdb_byte *unpacked;
220475ed 2556 const int is_scalar = is_scalar_type (type);
d0a9e810 2557 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2558 gdb::byte_vector staging;
f93fca70
JB
2559
2560 type = ada_check_typedef (type);
2561
d0a9e810 2562 if (obj == NULL)
bfb1c796 2563 src = valaddr + offset;
d0a9e810 2564 else
bfb1c796 2565 src = value_contents (obj) + offset;
d0a9e810
JB
2566
2567 if (is_dynamic_type (type))
2568 {
2569 /* The length of TYPE might by dynamic, so we need to resolve
2570 TYPE in order to know its actual size, which we then use
2571 to create the contents buffer of the value we return.
2572 The difficulty is that the data containing our object is
2573 packed, and therefore maybe not at a byte boundary. So, what
2574 we do, is unpack the data into a byte-aligned buffer, and then
2575 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2576 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2577 staging.resize (staging_len);
d0a9e810
JB
2578
2579 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2580 staging.data (), staging.size (),
d0a9e810
JB
2581 is_big_endian, has_negatives (type),
2582 is_scalar);
d5722aa2 2583 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2584 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2585 {
2586 /* This happens when the length of the object is dynamic,
2587 and is actually smaller than the space reserved for it.
2588 For instance, in an array of variant records, the bit_size
2589 we're given is the array stride, which is constant and
2590 normally equal to the maximum size of its element.
2591 But, in reality, each element only actually spans a portion
2592 of that stride. */
2593 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2594 }
d0a9e810
JB
2595 }
2596
f93fca70
JB
2597 if (obj == NULL)
2598 {
2599 v = allocate_value (type);
bfb1c796 2600 src = valaddr + offset;
f93fca70
JB
2601 }
2602 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2603 {
0cafa88c 2604 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2605 gdb_byte *buf;
0cafa88c 2606
f93fca70 2607 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2608 buf = (gdb_byte *) alloca (src_len);
2609 read_memory (value_address (v), buf, src_len);
2610 src = buf;
f93fca70
JB
2611 }
2612 else
2613 {
2614 v = allocate_value (type);
bfb1c796 2615 src = value_contents (obj) + offset;
f93fca70
JB
2616 }
2617
2618 if (obj != NULL)
2619 {
2620 long new_offset = offset;
2621
2622 set_value_component_location (v, obj);
2623 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2624 set_value_bitsize (v, bit_size);
2625 if (value_bitpos (v) >= HOST_CHAR_BIT)
2626 {
2627 ++new_offset;
2628 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2629 }
2630 set_value_offset (v, new_offset);
2631
2632 /* Also set the parent value. This is needed when trying to
2633 assign a new value (in inferior memory). */
2634 set_value_parent (v, obj);
2635 }
2636 else
2637 set_value_bitsize (v, bit_size);
bfb1c796 2638 unpacked = value_contents_writeable (v);
f93fca70
JB
2639
2640 if (bit_size == 0)
2641 {
2642 memset (unpacked, 0, TYPE_LENGTH (type));
2643 return v;
2644 }
2645
d5722aa2 2646 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2647 {
d0a9e810
JB
2648 /* Small short-cut: If we've unpacked the data into a buffer
2649 of the same size as TYPE's length, then we can reuse that,
2650 instead of doing the unpacking again. */
d5722aa2 2651 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2652 }
d0a9e810
JB
2653 else
2654 ada_unpack_from_contents (src, bit_offset, bit_size,
2655 unpacked, TYPE_LENGTH (type),
2656 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2657
14f9c5c9
AS
2658 return v;
2659}
d2e4a39e 2660
14f9c5c9
AS
2661/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2662 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2663 not overlap. */
14f9c5c9 2664static void
fc1a4b47 2665move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2666 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2667{
2668 unsigned int accum, mask;
2669 int accum_bits, chunk_size;
2670
2671 target += targ_offset / HOST_CHAR_BIT;
2672 targ_offset %= HOST_CHAR_BIT;
2673 source += src_offset / HOST_CHAR_BIT;
2674 src_offset %= HOST_CHAR_BIT;
50810684 2675 if (bits_big_endian_p)
14f9c5c9
AS
2676 {
2677 accum = (unsigned char) *source;
2678 source += 1;
2679 accum_bits = HOST_CHAR_BIT - src_offset;
2680
d2e4a39e 2681 while (n > 0)
4c4b4cd2
PH
2682 {
2683 int unused_right;
5b4ee69b 2684
4c4b4cd2
PH
2685 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2686 accum_bits += HOST_CHAR_BIT;
2687 source += 1;
2688 chunk_size = HOST_CHAR_BIT - targ_offset;
2689 if (chunk_size > n)
2690 chunk_size = n;
2691 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2692 mask = ((1 << chunk_size) - 1) << unused_right;
2693 *target =
2694 (*target & ~mask)
2695 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2696 n -= chunk_size;
2697 accum_bits -= chunk_size;
2698 target += 1;
2699 targ_offset = 0;
2700 }
14f9c5c9
AS
2701 }
2702 else
2703 {
2704 accum = (unsigned char) *source >> src_offset;
2705 source += 1;
2706 accum_bits = HOST_CHAR_BIT - src_offset;
2707
d2e4a39e 2708 while (n > 0)
4c4b4cd2
PH
2709 {
2710 accum = accum + ((unsigned char) *source << accum_bits);
2711 accum_bits += HOST_CHAR_BIT;
2712 source += 1;
2713 chunk_size = HOST_CHAR_BIT - targ_offset;
2714 if (chunk_size > n)
2715 chunk_size = n;
2716 mask = ((1 << chunk_size) - 1) << targ_offset;
2717 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2718 n -= chunk_size;
2719 accum_bits -= chunk_size;
2720 accum >>= chunk_size;
2721 target += 1;
2722 targ_offset = 0;
2723 }
14f9c5c9
AS
2724 }
2725}
2726
14f9c5c9
AS
2727/* Store the contents of FROMVAL into the location of TOVAL.
2728 Return a new value with the location of TOVAL and contents of
2729 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2730 floating-point or non-scalar types. */
14f9c5c9 2731
d2e4a39e
AS
2732static struct value *
2733ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2734{
df407dfe
AC
2735 struct type *type = value_type (toval);
2736 int bits = value_bitsize (toval);
14f9c5c9 2737
52ce6436
PH
2738 toval = ada_coerce_ref (toval);
2739 fromval = ada_coerce_ref (fromval);
2740
2741 if (ada_is_direct_array_type (value_type (toval)))
2742 toval = ada_coerce_to_simple_array (toval);
2743 if (ada_is_direct_array_type (value_type (fromval)))
2744 fromval = ada_coerce_to_simple_array (fromval);
2745
88e3b34b 2746 if (!deprecated_value_modifiable (toval))
323e0a4a 2747 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2748
d2e4a39e 2749 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2750 && bits > 0
d2e4a39e 2751 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2752 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2753 {
df407dfe
AC
2754 int len = (value_bitpos (toval)
2755 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2756 int from_size;
224c3ddb 2757 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2758 struct value *val;
42ae5230 2759 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2760
2761 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2762 fromval = value_cast (type, fromval);
14f9c5c9 2763
52ce6436 2764 read_memory (to_addr, buffer, len);
aced2898
PH
2765 from_size = value_bitsize (fromval);
2766 if (from_size == 0)
2767 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2768 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2769 move_bits (buffer, value_bitpos (toval),
50810684 2770 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2771 else
50810684
UW
2772 move_bits (buffer, value_bitpos (toval),
2773 value_contents (fromval), 0, bits, 0);
972daa01 2774 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2775
14f9c5c9 2776 val = value_copy (toval);
0fd88904 2777 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2778 TYPE_LENGTH (type));
04624583 2779 deprecated_set_value_type (val, type);
d2e4a39e 2780
14f9c5c9
AS
2781 return val;
2782 }
2783
2784 return value_assign (toval, fromval);
2785}
2786
2787
7c512744
JB
2788/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2789 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2790 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2791 COMPONENT, and not the inferior's memory. The current contents
2792 of COMPONENT are ignored.
2793
2794 Although not part of the initial design, this function also works
2795 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2796 had a null address, and COMPONENT had an address which is equal to
2797 its offset inside CONTAINER. */
2798
52ce6436
PH
2799static void
2800value_assign_to_component (struct value *container, struct value *component,
2801 struct value *val)
2802{
2803 LONGEST offset_in_container =
42ae5230 2804 (LONGEST) (value_address (component) - value_address (container));
7c512744 2805 int bit_offset_in_container =
52ce6436
PH
2806 value_bitpos (component) - value_bitpos (container);
2807 int bits;
7c512744 2808
52ce6436
PH
2809 val = value_cast (value_type (component), val);
2810
2811 if (value_bitsize (component) == 0)
2812 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2813 else
2814 bits = value_bitsize (component);
2815
50810684 2816 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
7c512744 2817 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436
PH
2818 value_bitpos (container) + bit_offset_in_container,
2819 value_contents (val),
2820 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2821 bits, 1);
52ce6436 2822 else
7c512744 2823 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2824 value_bitpos (container) + bit_offset_in_container,
50810684 2825 value_contents (val), 0, bits, 0);
7c512744
JB
2826}
2827
4c4b4cd2
PH
2828/* The value of the element of array ARR at the ARITY indices given in IND.
2829 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2830 thereto. */
2831
d2e4a39e
AS
2832struct value *
2833ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2834{
2835 int k;
d2e4a39e
AS
2836 struct value *elt;
2837 struct type *elt_type;
14f9c5c9
AS
2838
2839 elt = ada_coerce_to_simple_array (arr);
2840
df407dfe 2841 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2842 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2843 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2844 return value_subscript_packed (elt, arity, ind);
2845
2846 for (k = 0; k < arity; k += 1)
2847 {
2848 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2849 error (_("too many subscripts (%d expected)"), k);
2497b498 2850 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2851 }
2852 return elt;
2853}
2854
deede10c
JB
2855/* Assuming ARR is a pointer to a GDB array, the value of the element
2856 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2857 Does not read the entire array into memory.
2858
2859 Note: Unlike what one would expect, this function is used instead of
2860 ada_value_subscript for basically all non-packed array types. The reason
2861 for this is that a side effect of doing our own pointer arithmetics instead
2862 of relying on value_subscript is that there is no implicit typedef peeling.
2863 This is important for arrays of array accesses, where it allows us to
2864 preserve the fact that the array's element is an array access, where the
2865 access part os encoded in a typedef layer. */
14f9c5c9 2866
2c0b251b 2867static struct value *
deede10c 2868ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2869{
2870 int k;
919e6dbe 2871 struct value *array_ind = ada_value_ind (arr);
deede10c 2872 struct type *type
919e6dbe
PMR
2873 = check_typedef (value_enclosing_type (array_ind));
2874
2875 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2876 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2877 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2878
2879 for (k = 0; k < arity; k += 1)
2880 {
2881 LONGEST lwb, upb;
aa715135 2882 struct value *lwb_value;
14f9c5c9
AS
2883
2884 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2885 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2886 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2887 value_copy (arr));
14f9c5c9 2888 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2889 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2890 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2891 type = TYPE_TARGET_TYPE (type);
2892 }
2893
2894 return value_ind (arr);
2895}
2896
0b5d8877 2897/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2898 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2899 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2900 this array is LOW, as per Ada rules. */
0b5d8877 2901static struct value *
f5938064
JG
2902ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2903 int low, int high)
0b5d8877 2904{
b0dd7688 2905 struct type *type0 = ada_check_typedef (type);
aa715135 2906 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2907 struct type *index_type
aa715135 2908 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2909 struct type *slice_type = create_array_type_with_stride
2910 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2911 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2912 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2913 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2914 LONGEST base_low_pos, low_pos;
2915 CORE_ADDR base;
2916
2917 if (!discrete_position (base_index_type, low, &low_pos)
2918 || !discrete_position (base_index_type, base_low, &base_low_pos))
2919 {
2920 warning (_("unable to get positions in slice, use bounds instead"));
2921 low_pos = low;
2922 base_low_pos = base_low;
2923 }
5b4ee69b 2924
aa715135
JG
2925 base = value_as_address (array_ptr)
2926 + ((low_pos - base_low_pos)
2927 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2928 return value_at_lazy (slice_type, base);
0b5d8877
PH
2929}
2930
2931
2932static struct value *
2933ada_value_slice (struct value *array, int low, int high)
2934{
b0dd7688 2935 struct type *type = ada_check_typedef (value_type (array));
aa715135 2936 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2937 struct type *index_type
2938 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2939 struct type *slice_type = create_array_type_with_stride
2940 (NULL, TYPE_TARGET_TYPE (type), index_type,
2941 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2942 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2943 LONGEST low_pos, high_pos;
5b4ee69b 2944
aa715135
JG
2945 if (!discrete_position (base_index_type, low, &low_pos)
2946 || !discrete_position (base_index_type, high, &high_pos))
2947 {
2948 warning (_("unable to get positions in slice, use bounds instead"));
2949 low_pos = low;
2950 high_pos = high;
2951 }
2952
2953 return value_cast (slice_type,
2954 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2955}
2956
14f9c5c9
AS
2957/* If type is a record type in the form of a standard GNAT array
2958 descriptor, returns the number of dimensions for type. If arr is a
2959 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2960 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2961
2962int
d2e4a39e 2963ada_array_arity (struct type *type)
14f9c5c9
AS
2964{
2965 int arity;
2966
2967 if (type == NULL)
2968 return 0;
2969
2970 type = desc_base_type (type);
2971
2972 arity = 0;
d2e4a39e 2973 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2974 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2975 else
2976 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2977 {
4c4b4cd2 2978 arity += 1;
61ee279c 2979 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2980 }
d2e4a39e 2981
14f9c5c9
AS
2982 return arity;
2983}
2984
2985/* If TYPE is a record type in the form of a standard GNAT array
2986 descriptor or a simple array type, returns the element type for
2987 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2988 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2989
d2e4a39e
AS
2990struct type *
2991ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2992{
2993 type = desc_base_type (type);
2994
d2e4a39e 2995 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2996 {
2997 int k;
d2e4a39e 2998 struct type *p_array_type;
14f9c5c9 2999
556bdfd4 3000 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
3001
3002 k = ada_array_arity (type);
3003 if (k == 0)
4c4b4cd2 3004 return NULL;
d2e4a39e 3005
4c4b4cd2 3006 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 3007 if (nindices >= 0 && k > nindices)
4c4b4cd2 3008 k = nindices;
d2e4a39e 3009 while (k > 0 && p_array_type != NULL)
4c4b4cd2 3010 {
61ee279c 3011 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
3012 k -= 1;
3013 }
14f9c5c9
AS
3014 return p_array_type;
3015 }
3016 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3017 {
3018 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3019 {
3020 type = TYPE_TARGET_TYPE (type);
3021 nindices -= 1;
3022 }
14f9c5c9
AS
3023 return type;
3024 }
3025
3026 return NULL;
3027}
3028
4c4b4cd2 3029/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3030 Does not examine memory. Throws an error if N is invalid or TYPE
3031 is not an array type. NAME is the name of the Ada attribute being
3032 evaluated ('range, 'first, 'last, or 'length); it is used in building
3033 the error message. */
14f9c5c9 3034
1eea4ebd
UW
3035static struct type *
3036ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3037{
4c4b4cd2
PH
3038 struct type *result_type;
3039
14f9c5c9
AS
3040 type = desc_base_type (type);
3041
1eea4ebd
UW
3042 if (n < 0 || n > ada_array_arity (type))
3043 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3044
4c4b4cd2 3045 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3046 {
3047 int i;
3048
3049 for (i = 1; i < n; i += 1)
4c4b4cd2 3050 type = TYPE_TARGET_TYPE (type);
262452ec 3051 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3052 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3053 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3054 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3055 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3056 result_type = NULL;
14f9c5c9 3057 }
d2e4a39e 3058 else
1eea4ebd
UW
3059 {
3060 result_type = desc_index_type (desc_bounds_type (type), n);
3061 if (result_type == NULL)
3062 error (_("attempt to take bound of something that is not an array"));
3063 }
3064
3065 return result_type;
14f9c5c9
AS
3066}
3067
3068/* Given that arr is an array type, returns the lower bound of the
3069 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3070 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3071 array-descriptor type. It works for other arrays with bounds supplied
3072 by run-time quantities other than discriminants. */
14f9c5c9 3073
abb68b3e 3074static LONGEST
fb5e3d5c 3075ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3076{
8a48ac95 3077 struct type *type, *index_type_desc, *index_type;
1ce677a4 3078 int i;
262452ec
JK
3079
3080 gdb_assert (which == 0 || which == 1);
14f9c5c9 3081
ad82864c
JB
3082 if (ada_is_constrained_packed_array_type (arr_type))
3083 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3084
4c4b4cd2 3085 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3086 return (LONGEST) - which;
14f9c5c9
AS
3087
3088 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3089 type = TYPE_TARGET_TYPE (arr_type);
3090 else
3091 type = arr_type;
3092
bafffb51
JB
3093 if (TYPE_FIXED_INSTANCE (type))
3094 {
3095 /* The array has already been fixed, so we do not need to
3096 check the parallel ___XA type again. That encoding has
3097 already been applied, so ignore it now. */
3098 index_type_desc = NULL;
3099 }
3100 else
3101 {
3102 index_type_desc = ada_find_parallel_type (type, "___XA");
3103 ada_fixup_array_indexes_type (index_type_desc);
3104 }
3105
262452ec 3106 if (index_type_desc != NULL)
28c85d6c
JB
3107 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3108 NULL);
262452ec 3109 else
8a48ac95
JB
3110 {
3111 struct type *elt_type = check_typedef (type);
3112
3113 for (i = 1; i < n; i++)
3114 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3115
3116 index_type = TYPE_INDEX_TYPE (elt_type);
3117 }
262452ec 3118
43bbcdc2
PH
3119 return
3120 (LONGEST) (which == 0
3121 ? ada_discrete_type_low_bound (index_type)
3122 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3123}
3124
3125/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3126 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3127 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3128 supplied by run-time quantities other than discriminants. */
14f9c5c9 3129
1eea4ebd 3130static LONGEST
4dc81987 3131ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3132{
eb479039
JB
3133 struct type *arr_type;
3134
3135 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3136 arr = value_ind (arr);
3137 arr_type = value_enclosing_type (arr);
14f9c5c9 3138
ad82864c
JB
3139 if (ada_is_constrained_packed_array_type (arr_type))
3140 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3141 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3142 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3143 else
1eea4ebd 3144 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3145}
3146
3147/* Given that arr is an array value, returns the length of the
3148 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3149 supplied by run-time quantities other than discriminants.
3150 Does not work for arrays indexed by enumeration types with representation
3151 clauses at the moment. */
14f9c5c9 3152
1eea4ebd 3153static LONGEST
d2e4a39e 3154ada_array_length (struct value *arr, int n)
14f9c5c9 3155{
aa715135
JG
3156 struct type *arr_type, *index_type;
3157 int low, high;
eb479039
JB
3158
3159 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3160 arr = value_ind (arr);
3161 arr_type = value_enclosing_type (arr);
14f9c5c9 3162
ad82864c
JB
3163 if (ada_is_constrained_packed_array_type (arr_type))
3164 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3165
4c4b4cd2 3166 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3167 {
3168 low = ada_array_bound_from_type (arr_type, n, 0);
3169 high = ada_array_bound_from_type (arr_type, n, 1);
3170 }
14f9c5c9 3171 else
aa715135
JG
3172 {
3173 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3174 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3175 }
3176
f168693b 3177 arr_type = check_typedef (arr_type);
7150d33c 3178 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3179 if (index_type != NULL)
3180 {
3181 struct type *base_type;
3182 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3183 base_type = TYPE_TARGET_TYPE (index_type);
3184 else
3185 base_type = index_type;
3186
3187 low = pos_atr (value_from_longest (base_type, low));
3188 high = pos_atr (value_from_longest (base_type, high));
3189 }
3190 return high - low + 1;
4c4b4cd2
PH
3191}
3192
3193/* An empty array whose type is that of ARR_TYPE (an array type),
3194 with bounds LOW to LOW-1. */
3195
3196static struct value *
3197empty_array (struct type *arr_type, int low)
3198{
b0dd7688 3199 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3200 struct type *index_type
3201 = create_static_range_type
3202 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3203 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3204
0b5d8877 3205 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3206}
14f9c5c9 3207\f
d2e4a39e 3208
4c4b4cd2 3209 /* Name resolution */
14f9c5c9 3210
4c4b4cd2
PH
3211/* The "decoded" name for the user-definable Ada operator corresponding
3212 to OP. */
14f9c5c9 3213
d2e4a39e 3214static const char *
4c4b4cd2 3215ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3216{
3217 int i;
3218
4c4b4cd2 3219 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3220 {
3221 if (ada_opname_table[i].op == op)
4c4b4cd2 3222 return ada_opname_table[i].decoded;
14f9c5c9 3223 }
323e0a4a 3224 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3225}
3226
3227
4c4b4cd2
PH
3228/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3229 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3230 undefined namespace) and converts operators that are
3231 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3232 non-null, it provides a preferred result type [at the moment, only
3233 type void has any effect---causing procedures to be preferred over
3234 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3235 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3236
4c4b4cd2 3237static void
e9d9f57e 3238resolve (expression_up *expp, int void_context_p)
14f9c5c9 3239{
30b15541
UW
3240 struct type *context_type = NULL;
3241 int pc = 0;
3242
3243 if (void_context_p)
3244 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3245
3246 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3247}
3248
4c4b4cd2
PH
3249/* Resolve the operator of the subexpression beginning at
3250 position *POS of *EXPP. "Resolving" consists of replacing
3251 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3252 with their resolutions, replacing built-in operators with
3253 function calls to user-defined operators, where appropriate, and,
3254 when DEPROCEDURE_P is non-zero, converting function-valued variables
3255 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3256 are as in ada_resolve, above. */
14f9c5c9 3257
d2e4a39e 3258static struct value *
e9d9f57e 3259resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
76a01679 3260 struct type *context_type)
14f9c5c9
AS
3261{
3262 int pc = *pos;
3263 int i;
4c4b4cd2 3264 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3265 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3266 struct value **argvec; /* Vector of operand types (alloca'ed). */
3267 int nargs; /* Number of operands. */
52ce6436 3268 int oplen;
14f9c5c9
AS
3269
3270 argvec = NULL;
3271 nargs = 0;
e9d9f57e 3272 exp = expp->get ();
14f9c5c9 3273
52ce6436
PH
3274 /* Pass one: resolve operands, saving their types and updating *pos,
3275 if needed. */
14f9c5c9
AS
3276 switch (op)
3277 {
4c4b4cd2
PH
3278 case OP_FUNCALL:
3279 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3280 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3281 *pos += 7;
4c4b4cd2
PH
3282 else
3283 {
3284 *pos += 3;
3285 resolve_subexp (expp, pos, 0, NULL);
3286 }
3287 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3288 break;
3289
14f9c5c9 3290 case UNOP_ADDR:
4c4b4cd2
PH
3291 *pos += 1;
3292 resolve_subexp (expp, pos, 0, NULL);
3293 break;
3294
52ce6436
PH
3295 case UNOP_QUAL:
3296 *pos += 3;
17466c1a 3297 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3298 break;
3299
52ce6436 3300 case OP_ATR_MODULUS:
4c4b4cd2
PH
3301 case OP_ATR_SIZE:
3302 case OP_ATR_TAG:
4c4b4cd2
PH
3303 case OP_ATR_FIRST:
3304 case OP_ATR_LAST:
3305 case OP_ATR_LENGTH:
3306 case OP_ATR_POS:
3307 case OP_ATR_VAL:
4c4b4cd2
PH
3308 case OP_ATR_MIN:
3309 case OP_ATR_MAX:
52ce6436
PH
3310 case TERNOP_IN_RANGE:
3311 case BINOP_IN_BOUNDS:
3312 case UNOP_IN_RANGE:
3313 case OP_AGGREGATE:
3314 case OP_OTHERS:
3315 case OP_CHOICES:
3316 case OP_POSITIONAL:
3317 case OP_DISCRETE_RANGE:
3318 case OP_NAME:
3319 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3320 *pos += oplen;
14f9c5c9
AS
3321 break;
3322
3323 case BINOP_ASSIGN:
3324 {
4c4b4cd2
PH
3325 struct value *arg1;
3326
3327 *pos += 1;
3328 arg1 = resolve_subexp (expp, pos, 0, NULL);
3329 if (arg1 == NULL)
3330 resolve_subexp (expp, pos, 1, NULL);
3331 else
df407dfe 3332 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3333 break;
14f9c5c9
AS
3334 }
3335
4c4b4cd2 3336 case UNOP_CAST:
4c4b4cd2
PH
3337 *pos += 3;
3338 nargs = 1;
3339 break;
14f9c5c9 3340
4c4b4cd2
PH
3341 case BINOP_ADD:
3342 case BINOP_SUB:
3343 case BINOP_MUL:
3344 case BINOP_DIV:
3345 case BINOP_REM:
3346 case BINOP_MOD:
3347 case BINOP_EXP:
3348 case BINOP_CONCAT:
3349 case BINOP_LOGICAL_AND:
3350 case BINOP_LOGICAL_OR:
3351 case BINOP_BITWISE_AND:
3352 case BINOP_BITWISE_IOR:
3353 case BINOP_BITWISE_XOR:
14f9c5c9 3354
4c4b4cd2
PH
3355 case BINOP_EQUAL:
3356 case BINOP_NOTEQUAL:
3357 case BINOP_LESS:
3358 case BINOP_GTR:
3359 case BINOP_LEQ:
3360 case BINOP_GEQ:
14f9c5c9 3361
4c4b4cd2
PH
3362 case BINOP_REPEAT:
3363 case BINOP_SUBSCRIPT:
3364 case BINOP_COMMA:
40c8aaa9
JB
3365 *pos += 1;
3366 nargs = 2;
3367 break;
14f9c5c9 3368
4c4b4cd2
PH
3369 case UNOP_NEG:
3370 case UNOP_PLUS:
3371 case UNOP_LOGICAL_NOT:
3372 case UNOP_ABS:
3373 case UNOP_IND:
3374 *pos += 1;
3375 nargs = 1;
3376 break;
14f9c5c9 3377
4c4b4cd2 3378 case OP_LONG:
edd079d9 3379 case OP_FLOAT:
4c4b4cd2 3380 case OP_VAR_VALUE:
74ea4be4 3381 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3382 *pos += 4;
3383 break;
14f9c5c9 3384
4c4b4cd2
PH
3385 case OP_TYPE:
3386 case OP_BOOL:
3387 case OP_LAST:
4c4b4cd2
PH
3388 case OP_INTERNALVAR:
3389 *pos += 3;
3390 break;
14f9c5c9 3391
4c4b4cd2
PH
3392 case UNOP_MEMVAL:
3393 *pos += 3;
3394 nargs = 1;
3395 break;
3396
67f3407f
DJ
3397 case OP_REGISTER:
3398 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3399 break;
3400
4c4b4cd2
PH
3401 case STRUCTOP_STRUCT:
3402 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3403 nargs = 1;
3404 break;
3405
4c4b4cd2 3406 case TERNOP_SLICE:
4c4b4cd2
PH
3407 *pos += 1;
3408 nargs = 3;
3409 break;
3410
52ce6436 3411 case OP_STRING:
14f9c5c9 3412 break;
4c4b4cd2
PH
3413
3414 default:
323e0a4a 3415 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3416 }
3417
8d749320 3418 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2
PH
3419 for (i = 0; i < nargs; i += 1)
3420 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3421 argvec[i] = NULL;
e9d9f57e 3422 exp = expp->get ();
4c4b4cd2
PH
3423
3424 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3425 switch (op)
3426 {
3427 default:
3428 break;
3429
14f9c5c9 3430 case OP_VAR_VALUE:
4c4b4cd2 3431 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3432 {
54d343a2 3433 std::vector<struct block_symbol> candidates;
76a01679
JB
3434 int n_candidates;
3435
3436 n_candidates =
3437 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3438 (exp->elts[pc + 2].symbol),
3439 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3440 &candidates);
76a01679
JB
3441
3442 if (n_candidates > 1)
3443 {
3444 /* Types tend to get re-introduced locally, so if there
3445 are any local symbols that are not types, first filter
3446 out all types. */
3447 int j;
3448 for (j = 0; j < n_candidates; j += 1)
d12307c1 3449 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3450 {
3451 case LOC_REGISTER:
3452 case LOC_ARG:
3453 case LOC_REF_ARG:
76a01679
JB
3454 case LOC_REGPARM_ADDR:
3455 case LOC_LOCAL:
76a01679 3456 case LOC_COMPUTED:
76a01679
JB
3457 goto FoundNonType;
3458 default:
3459 break;
3460 }
3461 FoundNonType:
3462 if (j < n_candidates)
3463 {
3464 j = 0;
3465 while (j < n_candidates)
3466 {
d12307c1 3467 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3468 {
3469 candidates[j] = candidates[n_candidates - 1];
3470 n_candidates -= 1;
3471 }
3472 else
3473 j += 1;
3474 }
3475 }
3476 }
3477
3478 if (n_candidates == 0)
323e0a4a 3479 error (_("No definition found for %s"),
76a01679
JB
3480 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3481 else if (n_candidates == 1)
3482 i = 0;
3483 else if (deprocedure_p
54d343a2 3484 && !is_nonfunction (candidates.data (), n_candidates))
76a01679 3485 {
06d5cf63 3486 i = ada_resolve_function
54d343a2 3487 (candidates.data (), n_candidates, NULL, 0,
06d5cf63
JB
3488 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3489 context_type);
76a01679 3490 if (i < 0)
323e0a4a 3491 error (_("Could not find a match for %s"),
76a01679
JB
3492 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3493 }
3494 else
3495 {
323e0a4a 3496 printf_filtered (_("Multiple matches for %s\n"),
76a01679 3497 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
54d343a2 3498 user_select_syms (candidates.data (), n_candidates, 1);
76a01679
JB
3499 i = 0;
3500 }
3501
3502 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3503 exp->elts[pc + 2].symbol = candidates[i].symbol;
aee1fcdf 3504 innermost_block.update (candidates[i]);
76a01679
JB
3505 }
3506
3507 if (deprocedure_p
3508 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3509 == TYPE_CODE_FUNC))
3510 {
3511 replace_operator_with_call (expp, pc, 0, 0,
3512 exp->elts[pc + 2].symbol,
3513 exp->elts[pc + 1].block);
e9d9f57e 3514 exp = expp->get ();
76a01679 3515 }
14f9c5c9
AS
3516 break;
3517
3518 case OP_FUNCALL:
3519 {
4c4b4cd2 3520 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3521 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3522 {
54d343a2 3523 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3524 int n_candidates;
3525
3526 n_candidates =
76a01679
JB
3527 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3528 (exp->elts[pc + 5].symbol),
3529 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3530 &candidates);
ec6a20c2 3531
4c4b4cd2
PH
3532 if (n_candidates == 1)
3533 i = 0;
3534 else
3535 {
06d5cf63 3536 i = ada_resolve_function
54d343a2 3537 (candidates.data (), n_candidates,
06d5cf63
JB
3538 argvec, nargs,
3539 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3540 context_type);
4c4b4cd2 3541 if (i < 0)
323e0a4a 3542 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3543 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3544 }
3545
3546 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3547 exp->elts[pc + 5].symbol = candidates[i].symbol;
aee1fcdf 3548 innermost_block.update (candidates[i]);
4c4b4cd2 3549 }
14f9c5c9
AS
3550 }
3551 break;
3552 case BINOP_ADD:
3553 case BINOP_SUB:
3554 case BINOP_MUL:
3555 case BINOP_DIV:
3556 case BINOP_REM:
3557 case BINOP_MOD:
3558 case BINOP_CONCAT:
3559 case BINOP_BITWISE_AND:
3560 case BINOP_BITWISE_IOR:
3561 case BINOP_BITWISE_XOR:
3562 case BINOP_EQUAL:
3563 case BINOP_NOTEQUAL:
3564 case BINOP_LESS:
3565 case BINOP_GTR:
3566 case BINOP_LEQ:
3567 case BINOP_GEQ:
3568 case BINOP_EXP:
3569 case UNOP_NEG:
3570 case UNOP_PLUS:
3571 case UNOP_LOGICAL_NOT:
3572 case UNOP_ABS:
3573 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3574 {
54d343a2 3575 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3576 int n_candidates;
3577
3578 n_candidates =
b5ec771e 3579 ada_lookup_symbol_list (ada_decoded_op_name (op),
4c4b4cd2 3580 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3581 &candidates);
ec6a20c2 3582
54d343a2
TT
3583 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3584 nargs, ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3585 if (i < 0)
3586 break;
3587
d12307c1
PMR
3588 replace_operator_with_call (expp, pc, nargs, 1,
3589 candidates[i].symbol,
3590 candidates[i].block);
e9d9f57e 3591 exp = expp->get ();
4c4b4cd2 3592 }
14f9c5c9 3593 break;
4c4b4cd2
PH
3594
3595 case OP_TYPE:
b3dbf008 3596 case OP_REGISTER:
4c4b4cd2 3597 return NULL;
14f9c5c9
AS
3598 }
3599
3600 *pos = pc;
ced9779b
JB
3601 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3602 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3603 exp->elts[pc + 1].objfile,
3604 exp->elts[pc + 2].msymbol);
3605 else
3606 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3607}
3608
3609/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3610 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3611 a non-pointer. */
14f9c5c9 3612/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3613 liberal. */
14f9c5c9
AS
3614
3615static int
4dc81987 3616ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3617{
61ee279c
PH
3618 ftype = ada_check_typedef (ftype);
3619 atype = ada_check_typedef (atype);
14f9c5c9
AS
3620
3621 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3622 ftype = TYPE_TARGET_TYPE (ftype);
3623 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3624 atype = TYPE_TARGET_TYPE (atype);
3625
d2e4a39e 3626 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3627 {
3628 default:
5b3d5b7d 3629 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3630 case TYPE_CODE_PTR:
3631 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3632 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3633 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3634 else
1265e4aa
JB
3635 return (may_deref
3636 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3637 case TYPE_CODE_INT:
3638 case TYPE_CODE_ENUM:
3639 case TYPE_CODE_RANGE:
3640 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3641 {
3642 case TYPE_CODE_INT:
3643 case TYPE_CODE_ENUM:
3644 case TYPE_CODE_RANGE:
3645 return 1;
3646 default:
3647 return 0;
3648 }
14f9c5c9
AS
3649
3650 case TYPE_CODE_ARRAY:
d2e4a39e 3651 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3652 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3653
3654 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3655 if (ada_is_array_descriptor_type (ftype))
3656 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3657 || ada_is_array_descriptor_type (atype));
14f9c5c9 3658 else
4c4b4cd2
PH
3659 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3660 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3661
3662 case TYPE_CODE_UNION:
3663 case TYPE_CODE_FLT:
3664 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3665 }
3666}
3667
3668/* Return non-zero if the formals of FUNC "sufficiently match" the
3669 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3670 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3671 argument function. */
14f9c5c9
AS
3672
3673static int
d2e4a39e 3674ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3675{
3676 int i;
d2e4a39e 3677 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3678
1265e4aa
JB
3679 if (SYMBOL_CLASS (func) == LOC_CONST
3680 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3681 return (n_actuals == 0);
3682 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3683 return 0;
3684
3685 if (TYPE_NFIELDS (func_type) != n_actuals)
3686 return 0;
3687
3688 for (i = 0; i < n_actuals; i += 1)
3689 {
4c4b4cd2 3690 if (actuals[i] == NULL)
76a01679
JB
3691 return 0;
3692 else
3693 {
5b4ee69b
MS
3694 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3695 i));
df407dfe 3696 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3697
76a01679
JB
3698 if (!ada_type_match (ftype, atype, 1))
3699 return 0;
3700 }
14f9c5c9
AS
3701 }
3702 return 1;
3703}
3704
3705/* False iff function type FUNC_TYPE definitely does not produce a value
3706 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3707 FUNC_TYPE is not a valid function type with a non-null return type
3708 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3709
3710static int
d2e4a39e 3711return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3712{
d2e4a39e 3713 struct type *return_type;
14f9c5c9
AS
3714
3715 if (func_type == NULL)
3716 return 1;
3717
4c4b4cd2 3718 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3719 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3720 else
18af8284 3721 return_type = get_base_type (func_type);
14f9c5c9
AS
3722 if (return_type == NULL)
3723 return 1;
3724
18af8284 3725 context_type = get_base_type (context_type);
14f9c5c9
AS
3726
3727 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3728 return context_type == NULL || return_type == context_type;
3729 else if (context_type == NULL)
3730 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3731 else
3732 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3733}
3734
3735
4c4b4cd2 3736/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3737 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3738 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3739 that returns that type, then eliminate matches that don't. If
3740 CONTEXT_TYPE is void and there is at least one match that does not
3741 return void, eliminate all matches that do.
3742
14f9c5c9
AS
3743 Asks the user if there is more than one match remaining. Returns -1
3744 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3745 solely for messages. May re-arrange and modify SYMS in
3746 the process; the index returned is for the modified vector. */
14f9c5c9 3747
4c4b4cd2 3748static int
d12307c1 3749ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3750 int nsyms, struct value **args, int nargs,
3751 const char *name, struct type *context_type)
14f9c5c9 3752{
30b15541 3753 int fallback;
14f9c5c9 3754 int k;
4c4b4cd2 3755 int m; /* Number of hits */
14f9c5c9 3756
d2e4a39e 3757 m = 0;
30b15541
UW
3758 /* In the first pass of the loop, we only accept functions matching
3759 context_type. If none are found, we add a second pass of the loop
3760 where every function is accepted. */
3761 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3762 {
3763 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3764 {
d12307c1 3765 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3766
d12307c1 3767 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3768 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3769 {
3770 syms[m] = syms[k];
3771 m += 1;
3772 }
3773 }
14f9c5c9
AS
3774 }
3775
dc5c8746
PMR
3776 /* If we got multiple matches, ask the user which one to use. Don't do this
3777 interactive thing during completion, though, as the purpose of the
3778 completion is providing a list of all possible matches. Prompting the
3779 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3780 if (m == 0)
3781 return -1;
dc5c8746 3782 else if (m > 1 && !parse_completion)
14f9c5c9 3783 {
323e0a4a 3784 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3785 user_select_syms (syms, m, 1);
14f9c5c9
AS
3786 return 0;
3787 }
3788 return 0;
3789}
3790
4c4b4cd2
PH
3791/* Returns true (non-zero) iff decoded name N0 should appear before N1
3792 in a listing of choices during disambiguation (see sort_choices, below).
3793 The idea is that overloadings of a subprogram name from the
3794 same package should sort in their source order. We settle for ordering
3795 such symbols by their trailing number (__N or $N). */
3796
14f9c5c9 3797static int
0d5cff50 3798encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3799{
3800 if (N1 == NULL)
3801 return 0;
3802 else if (N0 == NULL)
3803 return 1;
3804 else
3805 {
3806 int k0, k1;
5b4ee69b 3807
d2e4a39e 3808 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3809 ;
d2e4a39e 3810 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3811 ;
d2e4a39e 3812 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3813 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3814 {
3815 int n0, n1;
5b4ee69b 3816
4c4b4cd2
PH
3817 n0 = k0;
3818 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3819 n0 -= 1;
3820 n1 = k1;
3821 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3822 n1 -= 1;
3823 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3824 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3825 }
14f9c5c9
AS
3826 return (strcmp (N0, N1) < 0);
3827 }
3828}
d2e4a39e 3829
4c4b4cd2
PH
3830/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3831 encoded names. */
3832
d2e4a39e 3833static void
d12307c1 3834sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3835{
4c4b4cd2 3836 int i;
5b4ee69b 3837
d2e4a39e 3838 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3839 {
d12307c1 3840 struct block_symbol sym = syms[i];
14f9c5c9
AS
3841 int j;
3842
d2e4a39e 3843 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3844 {
d12307c1
PMR
3845 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3846 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3847 break;
3848 syms[j + 1] = syms[j];
3849 }
d2e4a39e 3850 syms[j + 1] = sym;
14f9c5c9
AS
3851 }
3852}
3853
d72413e6
PMR
3854/* Whether GDB should display formals and return types for functions in the
3855 overloads selection menu. */
3856static int print_signatures = 1;
3857
3858/* Print the signature for SYM on STREAM according to the FLAGS options. For
3859 all but functions, the signature is just the name of the symbol. For
3860 functions, this is the name of the function, the list of types for formals
3861 and the return type (if any). */
3862
3863static void
3864ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3865 const struct type_print_options *flags)
3866{
3867 struct type *type = SYMBOL_TYPE (sym);
3868
3869 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3870 if (!print_signatures
3871 || type == NULL
3872 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3873 return;
3874
3875 if (TYPE_NFIELDS (type) > 0)
3876 {
3877 int i;
3878
3879 fprintf_filtered (stream, " (");
3880 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3881 {
3882 if (i > 0)
3883 fprintf_filtered (stream, "; ");
3884 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3885 flags);
3886 }
3887 fprintf_filtered (stream, ")");
3888 }
3889 if (TYPE_TARGET_TYPE (type) != NULL
3890 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3891 {
3892 fprintf_filtered (stream, " return ");
3893 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3894 }
3895}
3896
4c4b4cd2
PH
3897/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3898 by asking the user (if necessary), returning the number selected,
3899 and setting the first elements of SYMS items. Error if no symbols
3900 selected. */
14f9c5c9
AS
3901
3902/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3903 to be re-integrated one of these days. */
14f9c5c9
AS
3904
3905int
d12307c1 3906user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3907{
3908 int i;
8d749320 3909 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3910 int n_chosen;
3911 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3912 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3913
3914 if (max_results < 1)
323e0a4a 3915 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3916 if (nsyms <= 1)
3917 return nsyms;
3918
717d2f5a
JB
3919 if (select_mode == multiple_symbols_cancel)
3920 error (_("\
3921canceled because the command is ambiguous\n\
3922See set/show multiple-symbol."));
3923
3924 /* If select_mode is "all", then return all possible symbols.
3925 Only do that if more than one symbol can be selected, of course.
3926 Otherwise, display the menu as usual. */
3927 if (select_mode == multiple_symbols_all && max_results > 1)
3928 return nsyms;
3929
323e0a4a 3930 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3931 if (max_results > 1)
323e0a4a 3932 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3933
4c4b4cd2 3934 sort_choices (syms, nsyms);
14f9c5c9
AS
3935
3936 for (i = 0; i < nsyms; i += 1)
3937 {
d12307c1 3938 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3939 continue;
3940
d12307c1 3941 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3942 {
76a01679 3943 struct symtab_and_line sal =
d12307c1 3944 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3945
d72413e6
PMR
3946 printf_unfiltered ("[%d] ", i + first_choice);
3947 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3948 &type_print_raw_options);
323e0a4a 3949 if (sal.symtab == NULL)
d72413e6 3950 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3951 sal.line);
3952 else
d72413e6 3953 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3954 symtab_to_filename_for_display (sal.symtab),
3955 sal.line);
4c4b4cd2
PH
3956 continue;
3957 }
d2e4a39e 3958 else
4c4b4cd2
PH
3959 {
3960 int is_enumeral =
d12307c1
PMR
3961 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3962 && SYMBOL_TYPE (syms[i].symbol) != NULL
3963 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3964 struct symtab *symtab = NULL;
3965
d12307c1
PMR
3966 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3967 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3968
d12307c1 3969 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3970 {
3971 printf_unfiltered ("[%d] ", i + first_choice);
3972 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3973 &type_print_raw_options);
3974 printf_unfiltered (_(" at %s:%d\n"),
3975 symtab_to_filename_for_display (symtab),
3976 SYMBOL_LINE (syms[i].symbol));
3977 }
76a01679 3978 else if (is_enumeral
d12307c1 3979 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3980 {
a3f17187 3981 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3982 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3983 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3984 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3985 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3986 }
d72413e6
PMR
3987 else
3988 {
3989 printf_unfiltered ("[%d] ", i + first_choice);
3990 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3991 &type_print_raw_options);
3992
3993 if (symtab != NULL)
3994 printf_unfiltered (is_enumeral
3995 ? _(" in %s (enumeral)\n")
3996 : _(" at %s:?\n"),
3997 symtab_to_filename_for_display (symtab));
3998 else
3999 printf_unfiltered (is_enumeral
4000 ? _(" (enumeral)\n")
4001 : _(" at ?\n"));
4002 }
4c4b4cd2 4003 }
14f9c5c9 4004 }
d2e4a39e 4005
14f9c5c9 4006 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4007 "overload-choice");
14f9c5c9
AS
4008
4009 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4010 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4011
4012 return n_chosen;
4013}
4014
4015/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4016 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4017 order in CHOICES[0 .. N-1], and return N.
4018
4019 The user types choices as a sequence of numbers on one line
4020 separated by blanks, encoding them as follows:
4021
4c4b4cd2 4022 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4023 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4024 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4025
4c4b4cd2 4026 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4027
4028 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4029 prompts (for use with the -f switch). */
14f9c5c9
AS
4030
4031int
d2e4a39e 4032get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4033 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4034{
d2e4a39e 4035 char *args;
a121b7c1 4036 const char *prompt;
14f9c5c9
AS
4037 int n_chosen;
4038 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4039
14f9c5c9
AS
4040 prompt = getenv ("PS2");
4041 if (prompt == NULL)
0bcd0149 4042 prompt = "> ";
14f9c5c9 4043
0bcd0149 4044 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 4045
14f9c5c9 4046 if (args == NULL)
323e0a4a 4047 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4048
4049 n_chosen = 0;
76a01679 4050
4c4b4cd2
PH
4051 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4052 order, as given in args. Choices are validated. */
14f9c5c9
AS
4053 while (1)
4054 {
d2e4a39e 4055 char *args2;
14f9c5c9
AS
4056 int choice, j;
4057
0fcd72ba 4058 args = skip_spaces (args);
14f9c5c9 4059 if (*args == '\0' && n_chosen == 0)
323e0a4a 4060 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4061 else if (*args == '\0')
4c4b4cd2 4062 break;
14f9c5c9
AS
4063
4064 choice = strtol (args, &args2, 10);
d2e4a39e 4065 if (args == args2 || choice < 0
4c4b4cd2 4066 || choice > n_choices + first_choice - 1)
323e0a4a 4067 error (_("Argument must be choice number"));
14f9c5c9
AS
4068 args = args2;
4069
d2e4a39e 4070 if (choice == 0)
323e0a4a 4071 error (_("cancelled"));
14f9c5c9
AS
4072
4073 if (choice < first_choice)
4c4b4cd2
PH
4074 {
4075 n_chosen = n_choices;
4076 for (j = 0; j < n_choices; j += 1)
4077 choices[j] = j;
4078 break;
4079 }
14f9c5c9
AS
4080 choice -= first_choice;
4081
d2e4a39e 4082 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4083 {
4084 }
14f9c5c9
AS
4085
4086 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4087 {
4088 int k;
5b4ee69b 4089
4c4b4cd2
PH
4090 for (k = n_chosen - 1; k > j; k -= 1)
4091 choices[k + 1] = choices[k];
4092 choices[j + 1] = choice;
4093 n_chosen += 1;
4094 }
14f9c5c9
AS
4095 }
4096
4097 if (n_chosen > max_results)
323e0a4a 4098 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4099
14f9c5c9
AS
4100 return n_chosen;
4101}
4102
4c4b4cd2
PH
4103/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4104 on the function identified by SYM and BLOCK, and taking NARGS
4105 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4106
4107static void
e9d9f57e 4108replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4109 int oplen, struct symbol *sym,
270140bd 4110 const struct block *block)
14f9c5c9
AS
4111{
4112 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4113 symbol, -oplen for operator being replaced). */
d2e4a39e 4114 struct expression *newexp = (struct expression *)
8c1a34e7 4115 xzalloc (sizeof (struct expression)
4c4b4cd2 4116 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4117 struct expression *exp = expp->get ();
14f9c5c9
AS
4118
4119 newexp->nelts = exp->nelts + 7 - oplen;
4120 newexp->language_defn = exp->language_defn;
3489610d 4121 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4122 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4123 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4124 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4125
4126 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4127 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4128
4129 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4130 newexp->elts[pc + 4].block = block;
4131 newexp->elts[pc + 5].symbol = sym;
4132
e9d9f57e 4133 expp->reset (newexp);
d2e4a39e 4134}
14f9c5c9
AS
4135
4136/* Type-class predicates */
4137
4c4b4cd2
PH
4138/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4139 or FLOAT). */
14f9c5c9
AS
4140
4141static int
d2e4a39e 4142numeric_type_p (struct type *type)
14f9c5c9
AS
4143{
4144 if (type == NULL)
4145 return 0;
d2e4a39e
AS
4146 else
4147 {
4148 switch (TYPE_CODE (type))
4c4b4cd2
PH
4149 {
4150 case TYPE_CODE_INT:
4151 case TYPE_CODE_FLT:
4152 return 1;
4153 case TYPE_CODE_RANGE:
4154 return (type == TYPE_TARGET_TYPE (type)
4155 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4156 default:
4157 return 0;
4158 }
d2e4a39e 4159 }
14f9c5c9
AS
4160}
4161
4c4b4cd2 4162/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4163
4164static int
d2e4a39e 4165integer_type_p (struct type *type)
14f9c5c9
AS
4166{
4167 if (type == NULL)
4168 return 0;
d2e4a39e
AS
4169 else
4170 {
4171 switch (TYPE_CODE (type))
4c4b4cd2
PH
4172 {
4173 case TYPE_CODE_INT:
4174 return 1;
4175 case TYPE_CODE_RANGE:
4176 return (type == TYPE_TARGET_TYPE (type)
4177 || integer_type_p (TYPE_TARGET_TYPE (type)));
4178 default:
4179 return 0;
4180 }
d2e4a39e 4181 }
14f9c5c9
AS
4182}
4183
4c4b4cd2 4184/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4185
4186static int
d2e4a39e 4187scalar_type_p (struct type *type)
14f9c5c9
AS
4188{
4189 if (type == NULL)
4190 return 0;
d2e4a39e
AS
4191 else
4192 {
4193 switch (TYPE_CODE (type))
4c4b4cd2
PH
4194 {
4195 case TYPE_CODE_INT:
4196 case TYPE_CODE_RANGE:
4197 case TYPE_CODE_ENUM:
4198 case TYPE_CODE_FLT:
4199 return 1;
4200 default:
4201 return 0;
4202 }
d2e4a39e 4203 }
14f9c5c9
AS
4204}
4205
4c4b4cd2 4206/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4207
4208static int
d2e4a39e 4209discrete_type_p (struct type *type)
14f9c5c9
AS
4210{
4211 if (type == NULL)
4212 return 0;
d2e4a39e
AS
4213 else
4214 {
4215 switch (TYPE_CODE (type))
4c4b4cd2
PH
4216 {
4217 case TYPE_CODE_INT:
4218 case TYPE_CODE_RANGE:
4219 case TYPE_CODE_ENUM:
872f0337 4220 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4221 return 1;
4222 default:
4223 return 0;
4224 }
d2e4a39e 4225 }
14f9c5c9
AS
4226}
4227
4c4b4cd2
PH
4228/* Returns non-zero if OP with operands in the vector ARGS could be
4229 a user-defined function. Errs on the side of pre-defined operators
4230 (i.e., result 0). */
14f9c5c9
AS
4231
4232static int
d2e4a39e 4233possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4234{
76a01679 4235 struct type *type0 =
df407dfe 4236 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4237 struct type *type1 =
df407dfe 4238 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4239
4c4b4cd2
PH
4240 if (type0 == NULL)
4241 return 0;
4242
14f9c5c9
AS
4243 switch (op)
4244 {
4245 default:
4246 return 0;
4247
4248 case BINOP_ADD:
4249 case BINOP_SUB:
4250 case BINOP_MUL:
4251 case BINOP_DIV:
d2e4a39e 4252 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4253
4254 case BINOP_REM:
4255 case BINOP_MOD:
4256 case BINOP_BITWISE_AND:
4257 case BINOP_BITWISE_IOR:
4258 case BINOP_BITWISE_XOR:
d2e4a39e 4259 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4260
4261 case BINOP_EQUAL:
4262 case BINOP_NOTEQUAL:
4263 case BINOP_LESS:
4264 case BINOP_GTR:
4265 case BINOP_LEQ:
4266 case BINOP_GEQ:
d2e4a39e 4267 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4268
4269 case BINOP_CONCAT:
ee90b9ab 4270 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4271
4272 case BINOP_EXP:
d2e4a39e 4273 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4274
4275 case UNOP_NEG:
4276 case UNOP_PLUS:
4277 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4278 case UNOP_ABS:
4279 return (!numeric_type_p (type0));
14f9c5c9
AS
4280
4281 }
4282}
4283\f
4c4b4cd2 4284 /* Renaming */
14f9c5c9 4285
aeb5907d
JB
4286/* NOTES:
4287
4288 1. In the following, we assume that a renaming type's name may
4289 have an ___XD suffix. It would be nice if this went away at some
4290 point.
4291 2. We handle both the (old) purely type-based representation of
4292 renamings and the (new) variable-based encoding. At some point,
4293 it is devoutly to be hoped that the former goes away
4294 (FIXME: hilfinger-2007-07-09).
4295 3. Subprogram renamings are not implemented, although the XRS
4296 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4297
4298/* If SYM encodes a renaming,
4299
4300 <renaming> renames <renamed entity>,
4301
4302 sets *LEN to the length of the renamed entity's name,
4303 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4304 the string describing the subcomponent selected from the renamed
0963b4bd 4305 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4306 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4307 are undefined). Otherwise, returns a value indicating the category
4308 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4309 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4310 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4311 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4312 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4313 may be NULL, in which case they are not assigned.
4314
4315 [Currently, however, GCC does not generate subprogram renamings.] */
4316
4317enum ada_renaming_category
4318ada_parse_renaming (struct symbol *sym,
4319 const char **renamed_entity, int *len,
4320 const char **renaming_expr)
4321{
4322 enum ada_renaming_category kind;
4323 const char *info;
4324 const char *suffix;
4325
4326 if (sym == NULL)
4327 return ADA_NOT_RENAMING;
4328 switch (SYMBOL_CLASS (sym))
14f9c5c9 4329 {
aeb5907d
JB
4330 default:
4331 return ADA_NOT_RENAMING;
4332 case LOC_TYPEDEF:
4333 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4334 renamed_entity, len, renaming_expr);
4335 case LOC_LOCAL:
4336 case LOC_STATIC:
4337 case LOC_COMPUTED:
4338 case LOC_OPTIMIZED_OUT:
4339 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4340 if (info == NULL)
4341 return ADA_NOT_RENAMING;
4342 switch (info[5])
4343 {
4344 case '_':
4345 kind = ADA_OBJECT_RENAMING;
4346 info += 6;
4347 break;
4348 case 'E':
4349 kind = ADA_EXCEPTION_RENAMING;
4350 info += 7;
4351 break;
4352 case 'P':
4353 kind = ADA_PACKAGE_RENAMING;
4354 info += 7;
4355 break;
4356 case 'S':
4357 kind = ADA_SUBPROGRAM_RENAMING;
4358 info += 7;
4359 break;
4360 default:
4361 return ADA_NOT_RENAMING;
4362 }
14f9c5c9 4363 }
4c4b4cd2 4364
aeb5907d
JB
4365 if (renamed_entity != NULL)
4366 *renamed_entity = info;
4367 suffix = strstr (info, "___XE");
4368 if (suffix == NULL || suffix == info)
4369 return ADA_NOT_RENAMING;
4370 if (len != NULL)
4371 *len = strlen (info) - strlen (suffix);
4372 suffix += 5;
4373 if (renaming_expr != NULL)
4374 *renaming_expr = suffix;
4375 return kind;
4376}
4377
4378/* Assuming TYPE encodes a renaming according to the old encoding in
4379 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4380 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4381 ADA_NOT_RENAMING otherwise. */
4382static enum ada_renaming_category
4383parse_old_style_renaming (struct type *type,
4384 const char **renamed_entity, int *len,
4385 const char **renaming_expr)
4386{
4387 enum ada_renaming_category kind;
4388 const char *name;
4389 const char *info;
4390 const char *suffix;
14f9c5c9 4391
aeb5907d
JB
4392 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4393 || TYPE_NFIELDS (type) != 1)
4394 return ADA_NOT_RENAMING;
14f9c5c9 4395
a737d952 4396 name = TYPE_NAME (type);
aeb5907d
JB
4397 if (name == NULL)
4398 return ADA_NOT_RENAMING;
4399
4400 name = strstr (name, "___XR");
4401 if (name == NULL)
4402 return ADA_NOT_RENAMING;
4403 switch (name[5])
4404 {
4405 case '\0':
4406 case '_':
4407 kind = ADA_OBJECT_RENAMING;
4408 break;
4409 case 'E':
4410 kind = ADA_EXCEPTION_RENAMING;
4411 break;
4412 case 'P':
4413 kind = ADA_PACKAGE_RENAMING;
4414 break;
4415 case 'S':
4416 kind = ADA_SUBPROGRAM_RENAMING;
4417 break;
4418 default:
4419 return ADA_NOT_RENAMING;
4420 }
14f9c5c9 4421
aeb5907d
JB
4422 info = TYPE_FIELD_NAME (type, 0);
4423 if (info == NULL)
4424 return ADA_NOT_RENAMING;
4425 if (renamed_entity != NULL)
4426 *renamed_entity = info;
4427 suffix = strstr (info, "___XE");
4428 if (renaming_expr != NULL)
4429 *renaming_expr = suffix + 5;
4430 if (suffix == NULL || suffix == info)
4431 return ADA_NOT_RENAMING;
4432 if (len != NULL)
4433 *len = suffix - info;
4434 return kind;
a5ee536b
JB
4435}
4436
4437/* Compute the value of the given RENAMING_SYM, which is expected to
4438 be a symbol encoding a renaming expression. BLOCK is the block
4439 used to evaluate the renaming. */
52ce6436 4440
a5ee536b
JB
4441static struct value *
4442ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4443 const struct block *block)
a5ee536b 4444{
bbc13ae3 4445 const char *sym_name;
a5ee536b 4446
bbc13ae3 4447 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4448 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4449 return evaluate_expression (expr.get ());
a5ee536b 4450}
14f9c5c9 4451\f
d2e4a39e 4452
4c4b4cd2 4453 /* Evaluation: Function Calls */
14f9c5c9 4454
4c4b4cd2 4455/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4456 lvalues, and otherwise has the side-effect of allocating memory
4457 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4458
d2e4a39e 4459static struct value *
40bc484c 4460ensure_lval (struct value *val)
14f9c5c9 4461{
40bc484c
JB
4462 if (VALUE_LVAL (val) == not_lval
4463 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4464 {
df407dfe 4465 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4466 const CORE_ADDR addr =
4467 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4468
a84a8a0d 4469 VALUE_LVAL (val) = lval_memory;
1a088441 4470 set_value_address (val, addr);
40bc484c 4471 write_memory (addr, value_contents (val), len);
c3e5cd34 4472 }
14f9c5c9
AS
4473
4474 return val;
4475}
4476
4477/* Return the value ACTUAL, converted to be an appropriate value for a
4478 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4479 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4480 values not residing in memory, updating it as needed. */
14f9c5c9 4481
a93c0eb6 4482struct value *
40bc484c 4483ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4484{
df407dfe 4485 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4486 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4487 struct type *formal_target =
4488 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4489 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4490 struct type *actual_target =
4491 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4492 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4493
4c4b4cd2 4494 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4495 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4496 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4497 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4498 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4499 {
a84a8a0d 4500 struct value *result;
5b4ee69b 4501
14f9c5c9 4502 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4503 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4504 result = desc_data (actual);
cb923fcc 4505 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4506 {
4507 if (VALUE_LVAL (actual) != lval_memory)
4508 {
4509 struct value *val;
5b4ee69b 4510
df407dfe 4511 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4512 val = allocate_value (actual_type);
990a07ab 4513 memcpy ((char *) value_contents_raw (val),
0fd88904 4514 (char *) value_contents (actual),
4c4b4cd2 4515 TYPE_LENGTH (actual_type));
40bc484c 4516 actual = ensure_lval (val);
4c4b4cd2 4517 }
a84a8a0d 4518 result = value_addr (actual);
4c4b4cd2 4519 }
a84a8a0d
JB
4520 else
4521 return actual;
b1af9e97 4522 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4523 }
4524 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4525 return ada_value_ind (actual);
8344af1e
JB
4526 else if (ada_is_aligner_type (formal_type))
4527 {
4528 /* We need to turn this parameter into an aligner type
4529 as well. */
4530 struct value *aligner = allocate_value (formal_type);
4531 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4532
4533 value_assign_to_component (aligner, component, actual);
4534 return aligner;
4535 }
14f9c5c9
AS
4536
4537 return actual;
4538}
4539
438c98a1
JB
4540/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4541 type TYPE. This is usually an inefficient no-op except on some targets
4542 (such as AVR) where the representation of a pointer and an address
4543 differs. */
4544
4545static CORE_ADDR
4546value_pointer (struct value *value, struct type *type)
4547{
4548 struct gdbarch *gdbarch = get_type_arch (type);
4549 unsigned len = TYPE_LENGTH (type);
224c3ddb 4550 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4551 CORE_ADDR addr;
4552
4553 addr = value_address (value);
4554 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4555 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4556 return addr;
4557}
4558
14f9c5c9 4559
4c4b4cd2
PH
4560/* Push a descriptor of type TYPE for array value ARR on the stack at
4561 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4562 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4563 to-descriptor type rather than a descriptor type), a struct value *
4564 representing a pointer to this descriptor. */
14f9c5c9 4565
d2e4a39e 4566static struct value *
40bc484c 4567make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4568{
d2e4a39e
AS
4569 struct type *bounds_type = desc_bounds_type (type);
4570 struct type *desc_type = desc_base_type (type);
4571 struct value *descriptor = allocate_value (desc_type);
4572 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4573 int i;
d2e4a39e 4574
0963b4bd
MS
4575 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4576 i > 0; i -= 1)
14f9c5c9 4577 {
19f220c3
JK
4578 modify_field (value_type (bounds), value_contents_writeable (bounds),
4579 ada_array_bound (arr, i, 0),
4580 desc_bound_bitpos (bounds_type, i, 0),
4581 desc_bound_bitsize (bounds_type, i, 0));
4582 modify_field (value_type (bounds), value_contents_writeable (bounds),
4583 ada_array_bound (arr, i, 1),
4584 desc_bound_bitpos (bounds_type, i, 1),
4585 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4586 }
d2e4a39e 4587
40bc484c 4588 bounds = ensure_lval (bounds);
d2e4a39e 4589
19f220c3
JK
4590 modify_field (value_type (descriptor),
4591 value_contents_writeable (descriptor),
4592 value_pointer (ensure_lval (arr),
4593 TYPE_FIELD_TYPE (desc_type, 0)),
4594 fat_pntr_data_bitpos (desc_type),
4595 fat_pntr_data_bitsize (desc_type));
4596
4597 modify_field (value_type (descriptor),
4598 value_contents_writeable (descriptor),
4599 value_pointer (bounds,
4600 TYPE_FIELD_TYPE (desc_type, 1)),
4601 fat_pntr_bounds_bitpos (desc_type),
4602 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4603
40bc484c 4604 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4605
4606 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4607 return value_addr (descriptor);
4608 else
4609 return descriptor;
4610}
14f9c5c9 4611\f
3d9434b5
JB
4612 /* Symbol Cache Module */
4613
3d9434b5 4614/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4615 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4616 on the type of entity being printed, the cache can make it as much
4617 as an order of magnitude faster than without it.
4618
4619 The descriptive type DWARF extension has significantly reduced
4620 the need for this cache, at least when DWARF is being used. However,
4621 even in this case, some expensive name-based symbol searches are still
4622 sometimes necessary - to find an XVZ variable, mostly. */
4623
ee01b665 4624/* Initialize the contents of SYM_CACHE. */
3d9434b5 4625
ee01b665
JB
4626static void
4627ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4628{
4629 obstack_init (&sym_cache->cache_space);
4630 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4631}
3d9434b5 4632
ee01b665
JB
4633/* Free the memory used by SYM_CACHE. */
4634
4635static void
4636ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4637{
ee01b665
JB
4638 obstack_free (&sym_cache->cache_space, NULL);
4639 xfree (sym_cache);
4640}
3d9434b5 4641
ee01b665
JB
4642/* Return the symbol cache associated to the given program space PSPACE.
4643 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4644
ee01b665
JB
4645static struct ada_symbol_cache *
4646ada_get_symbol_cache (struct program_space *pspace)
4647{
4648 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4649
66c168ae 4650 if (pspace_data->sym_cache == NULL)
ee01b665 4651 {
66c168ae
JB
4652 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4653 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4654 }
4655
66c168ae 4656 return pspace_data->sym_cache;
ee01b665 4657}
3d9434b5
JB
4658
4659/* Clear all entries from the symbol cache. */
4660
4661static void
4662ada_clear_symbol_cache (void)
4663{
ee01b665
JB
4664 struct ada_symbol_cache *sym_cache
4665 = ada_get_symbol_cache (current_program_space);
4666
4667 obstack_free (&sym_cache->cache_space, NULL);
4668 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4669}
4670
fe978cb0 4671/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4672 Return it if found, or NULL otherwise. */
4673
4674static struct cache_entry **
fe978cb0 4675find_entry (const char *name, domain_enum domain)
3d9434b5 4676{
ee01b665
JB
4677 struct ada_symbol_cache *sym_cache
4678 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4679 int h = msymbol_hash (name) % HASH_SIZE;
4680 struct cache_entry **e;
4681
ee01b665 4682 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4683 {
fe978cb0 4684 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4685 return e;
4686 }
4687 return NULL;
4688}
4689
fe978cb0 4690/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4691 Return 1 if found, 0 otherwise.
4692
4693 If an entry was found and SYM is not NULL, set *SYM to the entry's
4694 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4695
96d887e8 4696static int
fe978cb0 4697lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4698 struct symbol **sym, const struct block **block)
96d887e8 4699{
fe978cb0 4700 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4701
4702 if (e == NULL)
4703 return 0;
4704 if (sym != NULL)
4705 *sym = (*e)->sym;
4706 if (block != NULL)
4707 *block = (*e)->block;
4708 return 1;
96d887e8
PH
4709}
4710
3d9434b5 4711/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4712 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4713
96d887e8 4714static void
fe978cb0 4715cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4716 const struct block *block)
96d887e8 4717{
ee01b665
JB
4718 struct ada_symbol_cache *sym_cache
4719 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4720 int h;
4721 char *copy;
4722 struct cache_entry *e;
4723
1994afbf
DE
4724 /* Symbols for builtin types don't have a block.
4725 For now don't cache such symbols. */
4726 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4727 return;
4728
3d9434b5
JB
4729 /* If the symbol is a local symbol, then do not cache it, as a search
4730 for that symbol depends on the context. To determine whether
4731 the symbol is local or not, we check the block where we found it
4732 against the global and static blocks of its associated symtab. */
4733 if (sym
08be3fe3 4734 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4735 GLOBAL_BLOCK) != block
08be3fe3 4736 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4737 STATIC_BLOCK) != block)
3d9434b5
JB
4738 return;
4739
4740 h = msymbol_hash (name) % HASH_SIZE;
e39db4db 4741 e = XOBNEW (&sym_cache->cache_space, cache_entry);
ee01b665
JB
4742 e->next = sym_cache->root[h];
4743 sym_cache->root[h] = e;
224c3ddb
SM
4744 e->name = copy
4745 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4746 strcpy (copy, name);
4747 e->sym = sym;
fe978cb0 4748 e->domain = domain;
3d9434b5 4749 e->block = block;
96d887e8 4750}
4c4b4cd2
PH
4751\f
4752 /* Symbol Lookup */
4753
b5ec771e
PA
4754/* Return the symbol name match type that should be used used when
4755 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4756
4757 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4758 for Ada lookups. */
c0431670 4759
b5ec771e
PA
4760static symbol_name_match_type
4761name_match_type_from_name (const char *lookup_name)
c0431670 4762{
b5ec771e
PA
4763 return (strstr (lookup_name, "__") == NULL
4764 ? symbol_name_match_type::WILD
4765 : symbol_name_match_type::FULL);
c0431670
JB
4766}
4767
4c4b4cd2
PH
4768/* Return the result of a standard (literal, C-like) lookup of NAME in
4769 given DOMAIN, visible from lexical block BLOCK. */
4770
4771static struct symbol *
4772standard_lookup (const char *name, const struct block *block,
4773 domain_enum domain)
4774{
acbd605d 4775 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4776 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4777
d12307c1
PMR
4778 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4779 return sym.symbol;
2570f2b7 4780 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4781 cache_symbol (name, domain, sym.symbol, sym.block);
4782 return sym.symbol;
4c4b4cd2
PH
4783}
4784
4785
4786/* Non-zero iff there is at least one non-function/non-enumeral symbol
4787 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4788 since they contend in overloading in the same way. */
4789static int
d12307c1 4790is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4791{
4792 int i;
4793
4794 for (i = 0; i < n; i += 1)
d12307c1
PMR
4795 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4796 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4797 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4798 return 1;
4799
4800 return 0;
4801}
4802
4803/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4804 struct types. Otherwise, they may not. */
14f9c5c9
AS
4805
4806static int
d2e4a39e 4807equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4808{
d2e4a39e 4809 if (type0 == type1)
14f9c5c9 4810 return 1;
d2e4a39e 4811 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4812 || TYPE_CODE (type0) != TYPE_CODE (type1))
4813 return 0;
d2e4a39e 4814 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4815 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4816 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4817 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4818 return 1;
d2e4a39e 4819
14f9c5c9
AS
4820 return 0;
4821}
4822
4823/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4824 no more defined than that of SYM1. */
14f9c5c9
AS
4825
4826static int
d2e4a39e 4827lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4828{
4829 if (sym0 == sym1)
4830 return 1;
176620f1 4831 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4832 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4833 return 0;
4834
d2e4a39e 4835 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4836 {
4837 case LOC_UNDEF:
4838 return 1;
4839 case LOC_TYPEDEF:
4840 {
4c4b4cd2
PH
4841 struct type *type0 = SYMBOL_TYPE (sym0);
4842 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4843 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4844 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4845 int len0 = strlen (name0);
5b4ee69b 4846
4c4b4cd2
PH
4847 return
4848 TYPE_CODE (type0) == TYPE_CODE (type1)
4849 && (equiv_types (type0, type1)
4850 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4851 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4852 }
4853 case LOC_CONST:
4854 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4855 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4856 default:
4857 return 0;
14f9c5c9
AS
4858 }
4859}
4860
d12307c1 4861/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4862 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4863
4864static void
76a01679
JB
4865add_defn_to_vec (struct obstack *obstackp,
4866 struct symbol *sym,
f0c5f9b2 4867 const struct block *block)
14f9c5c9
AS
4868{
4869 int i;
d12307c1 4870 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4871
529cad9c
PH
4872 /* Do not try to complete stub types, as the debugger is probably
4873 already scanning all symbols matching a certain name at the
4874 time when this function is called. Trying to replace the stub
4875 type by its associated full type will cause us to restart a scan
4876 which may lead to an infinite recursion. Instead, the client
4877 collecting the matching symbols will end up collecting several
4878 matches, with at least one of them complete. It can then filter
4879 out the stub ones if needed. */
4880
4c4b4cd2
PH
4881 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4882 {
d12307c1 4883 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4884 return;
d12307c1 4885 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4886 {
d12307c1 4887 prevDefns[i].symbol = sym;
4c4b4cd2 4888 prevDefns[i].block = block;
4c4b4cd2 4889 return;
76a01679 4890 }
4c4b4cd2
PH
4891 }
4892
4893 {
d12307c1 4894 struct block_symbol info;
4c4b4cd2 4895
d12307c1 4896 info.symbol = sym;
4c4b4cd2 4897 info.block = block;
d12307c1 4898 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4899 }
4900}
4901
d12307c1
PMR
4902/* Number of block_symbol structures currently collected in current vector in
4903 OBSTACKP. */
4c4b4cd2 4904
76a01679
JB
4905static int
4906num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4907{
d12307c1 4908 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4909}
4910
d12307c1
PMR
4911/* Vector of block_symbol structures currently collected in current vector in
4912 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4913
d12307c1 4914static struct block_symbol *
4c4b4cd2
PH
4915defns_collected (struct obstack *obstackp, int finish)
4916{
4917 if (finish)
224c3ddb 4918 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4919 else
d12307c1 4920 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4921}
4922
7c7b6655
TT
4923/* Return a bound minimal symbol matching NAME according to Ada
4924 decoding rules. Returns an invalid symbol if there is no such
4925 minimal symbol. Names prefixed with "standard__" are handled
4926 specially: "standard__" is first stripped off, and only static and
4927 global symbols are searched. */
4c4b4cd2 4928
7c7b6655 4929struct bound_minimal_symbol
96d887e8 4930ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4931{
7c7b6655 4932 struct bound_minimal_symbol result;
4c4b4cd2 4933 struct objfile *objfile;
96d887e8 4934 struct minimal_symbol *msymbol;
4c4b4cd2 4935
7c7b6655
TT
4936 memset (&result, 0, sizeof (result));
4937
b5ec771e
PA
4938 symbol_name_match_type match_type = name_match_type_from_name (name);
4939 lookup_name_info lookup_name (name, match_type);
4940
4941 symbol_name_matcher_ftype *match_name
4942 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4943
96d887e8
PH
4944 ALL_MSYMBOLS (objfile, msymbol)
4945 {
b5ec771e 4946 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
96d887e8 4947 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4948 {
4949 result.minsym = msymbol;
4950 result.objfile = objfile;
4951 break;
4952 }
96d887e8 4953 }
4c4b4cd2 4954
7c7b6655 4955 return result;
96d887e8 4956}
4c4b4cd2 4957
96d887e8
PH
4958/* For all subprograms that statically enclose the subprogram of the
4959 selected frame, add symbols matching identifier NAME in DOMAIN
4960 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4961 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4962 with a wildcard prefix. */
4c4b4cd2 4963
96d887e8
PH
4964static void
4965add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4966 const lookup_name_info &lookup_name,
4967 domain_enum domain)
96d887e8 4968{
96d887e8 4969}
14f9c5c9 4970
96d887e8
PH
4971/* True if TYPE is definitely an artificial type supplied to a symbol
4972 for which no debugging information was given in the symbol file. */
14f9c5c9 4973
96d887e8
PH
4974static int
4975is_nondebugging_type (struct type *type)
4976{
0d5cff50 4977 const char *name = ada_type_name (type);
5b4ee69b 4978
96d887e8
PH
4979 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4980}
4c4b4cd2 4981
8f17729f
JB
4982/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4983 that are deemed "identical" for practical purposes.
4984
4985 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4986 types and that their number of enumerals is identical (in other
4987 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4988
4989static int
4990ada_identical_enum_types_p (struct type *type1, struct type *type2)
4991{
4992 int i;
4993
4994 /* The heuristic we use here is fairly conservative. We consider
4995 that 2 enumerate types are identical if they have the same
4996 number of enumerals and that all enumerals have the same
4997 underlying value and name. */
4998
4999 /* All enums in the type should have an identical underlying value. */
5000 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 5001 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
5002 return 0;
5003
5004 /* All enumerals should also have the same name (modulo any numerical
5005 suffix). */
5006 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5007 {
0d5cff50
DE
5008 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5009 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5010 int len_1 = strlen (name_1);
5011 int len_2 = strlen (name_2);
5012
5013 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5014 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5015 if (len_1 != len_2
5016 || strncmp (TYPE_FIELD_NAME (type1, i),
5017 TYPE_FIELD_NAME (type2, i),
5018 len_1) != 0)
5019 return 0;
5020 }
5021
5022 return 1;
5023}
5024
5025/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5026 that are deemed "identical" for practical purposes. Sometimes,
5027 enumerals are not strictly identical, but their types are so similar
5028 that they can be considered identical.
5029
5030 For instance, consider the following code:
5031
5032 type Color is (Black, Red, Green, Blue, White);
5033 type RGB_Color is new Color range Red .. Blue;
5034
5035 Type RGB_Color is a subrange of an implicit type which is a copy
5036 of type Color. If we call that implicit type RGB_ColorB ("B" is
5037 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5038 As a result, when an expression references any of the enumeral
5039 by name (Eg. "print green"), the expression is technically
5040 ambiguous and the user should be asked to disambiguate. But
5041 doing so would only hinder the user, since it wouldn't matter
5042 what choice he makes, the outcome would always be the same.
5043 So, for practical purposes, we consider them as the same. */
5044
5045static int
54d343a2 5046symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
5047{
5048 int i;
5049
5050 /* Before performing a thorough comparison check of each type,
5051 we perform a series of inexpensive checks. We expect that these
5052 checks will quickly fail in the vast majority of cases, and thus
5053 help prevent the unnecessary use of a more expensive comparison.
5054 Said comparison also expects us to make some of these checks
5055 (see ada_identical_enum_types_p). */
5056
5057 /* Quick check: All symbols should have an enum type. */
54d343a2 5058 for (i = 0; i < syms.size (); i++)
d12307c1 5059 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5060 return 0;
5061
5062 /* Quick check: They should all have the same value. */
54d343a2 5063 for (i = 1; i < syms.size (); i++)
d12307c1 5064 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5065 return 0;
5066
5067 /* Quick check: They should all have the same number of enumerals. */
54d343a2 5068 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5069 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5070 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5071 return 0;
5072
5073 /* All the sanity checks passed, so we might have a set of
5074 identical enumeration types. Perform a more complete
5075 comparison of the type of each symbol. */
54d343a2 5076 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5077 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5078 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5079 return 0;
5080
5081 return 1;
5082}
5083
54d343a2 5084/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
5085 duplicate other symbols in the list (The only case I know of where
5086 this happens is when object files containing stabs-in-ecoff are
5087 linked with files containing ordinary ecoff debugging symbols (or no
5088 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5089 Returns the number of items in the modified list. */
4c4b4cd2 5090
96d887e8 5091static int
54d343a2 5092remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5093{
5094 int i, j;
4c4b4cd2 5095
8f17729f
JB
5096 /* We should never be called with less than 2 symbols, as there
5097 cannot be any extra symbol in that case. But it's easy to
5098 handle, since we have nothing to do in that case. */
54d343a2
TT
5099 if (syms->size () < 2)
5100 return syms->size ();
8f17729f 5101
96d887e8 5102 i = 0;
54d343a2 5103 while (i < syms->size ())
96d887e8 5104 {
a35ddb44 5105 int remove_p = 0;
339c13b6
JB
5106
5107 /* If two symbols have the same name and one of them is a stub type,
5108 the get rid of the stub. */
5109
54d343a2
TT
5110 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5111 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5112 {
54d343a2 5113 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5114 {
5115 if (j != i
54d343a2
TT
5116 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5117 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5118 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5119 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5120 remove_p = 1;
339c13b6
JB
5121 }
5122 }
5123
5124 /* Two symbols with the same name, same class and same address
5125 should be identical. */
5126
54d343a2
TT
5127 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5128 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5129 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5130 {
54d343a2 5131 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5132 {
5133 if (i != j
54d343a2
TT
5134 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5135 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5136 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5137 && SYMBOL_CLASS ((*syms)[i].symbol)
5138 == SYMBOL_CLASS ((*syms)[j].symbol)
5139 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5140 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5141 remove_p = 1;
4c4b4cd2 5142 }
4c4b4cd2 5143 }
339c13b6 5144
a35ddb44 5145 if (remove_p)
54d343a2 5146 syms->erase (syms->begin () + i);
339c13b6 5147
96d887e8 5148 i += 1;
14f9c5c9 5149 }
8f17729f
JB
5150
5151 /* If all the remaining symbols are identical enumerals, then
5152 just keep the first one and discard the rest.
5153
5154 Unlike what we did previously, we do not discard any entry
5155 unless they are ALL identical. This is because the symbol
5156 comparison is not a strict comparison, but rather a practical
5157 comparison. If all symbols are considered identical, then
5158 we can just go ahead and use the first one and discard the rest.
5159 But if we cannot reduce the list to a single element, we have
5160 to ask the user to disambiguate anyways. And if we have to
5161 present a multiple-choice menu, it's less confusing if the list
5162 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5163 if (symbols_are_identical_enums (*syms))
5164 syms->resize (1);
8f17729f 5165
54d343a2 5166 return syms->size ();
14f9c5c9
AS
5167}
5168
96d887e8
PH
5169/* Given a type that corresponds to a renaming entity, use the type name
5170 to extract the scope (package name or function name, fully qualified,
5171 and following the GNAT encoding convention) where this renaming has been
49d83361 5172 defined. */
4c4b4cd2 5173
49d83361 5174static std::string
96d887e8 5175xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5176{
96d887e8 5177 /* The renaming types adhere to the following convention:
0963b4bd 5178 <scope>__<rename>___<XR extension>.
96d887e8
PH
5179 So, to extract the scope, we search for the "___XR" extension,
5180 and then backtrack until we find the first "__". */
76a01679 5181
a737d952 5182 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5183 const char *suffix = strstr (name, "___XR");
5184 const char *last;
14f9c5c9 5185
96d887e8
PH
5186 /* Now, backtrack a bit until we find the first "__". Start looking
5187 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5188
96d887e8
PH
5189 for (last = suffix - 3; last > name; last--)
5190 if (last[0] == '_' && last[1] == '_')
5191 break;
76a01679 5192
96d887e8 5193 /* Make a copy of scope and return it. */
49d83361 5194 return std::string (name, last);
4c4b4cd2
PH
5195}
5196
96d887e8 5197/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5198
96d887e8
PH
5199static int
5200is_package_name (const char *name)
4c4b4cd2 5201{
96d887e8
PH
5202 /* Here, We take advantage of the fact that no symbols are generated
5203 for packages, while symbols are generated for each function.
5204 So the condition for NAME represent a package becomes equivalent
5205 to NAME not existing in our list of symbols. There is only one
5206 small complication with library-level functions (see below). */
4c4b4cd2 5207
96d887e8 5208 char *fun_name;
76a01679 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
b435e160 5223 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 5224
96d887e8
PH
5225 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
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 {
14bc53a8 5846 if (!callback (results[i].symbol))
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... */
12245 fi = get_prev_frame (fi);
12246 }
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
f17011e0
JB
13218 /* We can assume that SYM is not NULL at this stage. If the symbol
13219 did not exist, ada_exception_support_info_sniffer would have
13220 raised an exception.
f7f9143b 13221
f17011e0
JB
13222 Also, ada_exception_support_info_sniffer should have already
13223 verified that SYM is a function symbol. */
13224 gdb_assert (sym != NULL);
13225 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
13226
13227 /* Set ADDR_STRING. */
f7f9143b
JB
13228 *addr_string = xstrdup (sym_name);
13229
f7f9143b 13230 /* Set OPS. */
4b9eee8c 13231 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 13232
f17011e0 13233 return find_function_start_sal (sym, 1);
f7f9143b
JB
13234}
13235
b4a5b78b 13236/* Create an Ada exception catchpoint.
f7f9143b 13237
b4a5b78b 13238 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13239
bc18fbb5 13240 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
2df4d1d5 13241 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
bc18fbb5 13242 of the exception to which this catchpoint applies.
2df4d1d5 13243
bc18fbb5 13244 COND_STRING, if not empty, is the catchpoint condition.
f7f9143b 13245
b4a5b78b
JB
13246 TEMPFLAG, if nonzero, means that the underlying breakpoint
13247 should be temporary.
28010a5d 13248
b4a5b78b 13249 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13250
349774ef 13251void
28010a5d 13252create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13253 enum ada_exception_catchpoint_kind ex_kind,
bc18fbb5 13254 const std::string &excep_string,
56ecd069 13255 const std::string &cond_string,
28010a5d 13256 int tempflag,
349774ef 13257 int disabled,
28010a5d
PA
13258 int from_tty)
13259{
f2fc3015 13260 const char *addr_string = NULL;
b4a5b78b 13261 const struct breakpoint_ops *ops = NULL;
bc18fbb5 13262 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops);
28010a5d 13263
b270e6f9
TT
13264 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13265 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
349774ef 13266 ops, tempflag, disabled, from_tty);
28010a5d 13267 c->excep_string = excep_string;
9f757bf7 13268 create_excep_cond_exprs (c.get (), ex_kind);
56ecd069
XR
13269 if (!cond_string.empty ())
13270 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
b270e6f9 13271 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13272}
13273
9ac4176b
PA
13274/* Implement the "catch exception" command. */
13275
13276static void
eb4c3f4a 13277catch_ada_exception_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13278 struct cmd_list_element *command)
13279{
a121b7c1 13280 const char *arg = arg_entry;
9ac4176b
PA
13281 struct gdbarch *gdbarch = get_current_arch ();
13282 int tempflag;
761269c8 13283 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13284 std::string excep_string;
56ecd069 13285 std::string cond_string;
9ac4176b
PA
13286
13287 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13288
13289 if (!arg)
13290 arg = "";
9f757bf7 13291 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
bc18fbb5 13292 &cond_string);
9f757bf7
XR
13293 create_ada_exception_catchpoint (gdbarch, ex_kind,
13294 excep_string, cond_string,
13295 tempflag, 1 /* enabled */,
13296 from_tty);
13297}
13298
13299/* Implement the "catch handlers" command. */
13300
13301static void
13302catch_ada_handlers_command (const char *arg_entry, int from_tty,
13303 struct cmd_list_element *command)
13304{
13305 const char *arg = arg_entry;
13306 struct gdbarch *gdbarch = get_current_arch ();
13307 int tempflag;
13308 enum ada_exception_catchpoint_kind ex_kind;
bc18fbb5 13309 std::string excep_string;
56ecd069 13310 std::string cond_string;
9f757bf7
XR
13311
13312 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13313
13314 if (!arg)
13315 arg = "";
13316 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
bc18fbb5 13317 &cond_string);
b4a5b78b
JB
13318 create_ada_exception_catchpoint (gdbarch, ex_kind,
13319 excep_string, cond_string,
349774ef
JB
13320 tempflag, 1 /* enabled */,
13321 from_tty);
9ac4176b
PA
13322}
13323
b4a5b78b 13324/* Split the arguments specified in a "catch assert" command.
5845583d 13325
b4a5b78b
JB
13326 ARGS contains the command's arguments (or the empty string if
13327 no arguments were passed).
5845583d
JB
13328
13329 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13330 (the memory needs to be deallocated after use). */
5845583d 13331
b4a5b78b 13332static void
56ecd069 13333catch_ada_assert_command_split (const char *args, std::string &cond_string)
f7f9143b 13334{
f1735a53 13335 args = skip_spaces (args);
f7f9143b 13336
5845583d 13337 /* Check whether a condition was provided. */
61012eef 13338 if (startswith (args, "if")
5845583d 13339 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13340 {
5845583d 13341 args += 2;
f1735a53 13342 args = skip_spaces (args);
5845583d
JB
13343 if (args[0] == '\0')
13344 error (_("condition missing after `if' keyword"));
56ecd069 13345 cond_string.assign (args);
f7f9143b
JB
13346 }
13347
5845583d
JB
13348 /* Otherwise, there should be no other argument at the end of
13349 the command. */
13350 else if (args[0] != '\0')
13351 error (_("Junk at end of arguments."));
f7f9143b
JB
13352}
13353
9ac4176b
PA
13354/* Implement the "catch assert" command. */
13355
13356static void
eb4c3f4a 13357catch_assert_command (const char *arg_entry, int from_tty,
9ac4176b
PA
13358 struct cmd_list_element *command)
13359{
a121b7c1 13360 const char *arg = arg_entry;
9ac4176b
PA
13361 struct gdbarch *gdbarch = get_current_arch ();
13362 int tempflag;
56ecd069 13363 std::string cond_string;
9ac4176b
PA
13364
13365 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13366
13367 if (!arg)
13368 arg = "";
56ecd069 13369 catch_ada_assert_command_split (arg, cond_string);
761269c8 13370 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
241db429 13371 "", cond_string,
349774ef
JB
13372 tempflag, 1 /* enabled */,
13373 from_tty);
9ac4176b 13374}
778865d3
JB
13375
13376/* Return non-zero if the symbol SYM is an Ada exception object. */
13377
13378static int
13379ada_is_exception_sym (struct symbol *sym)
13380{
a737d952 13381 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym));
778865d3
JB
13382
13383 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13384 && SYMBOL_CLASS (sym) != LOC_BLOCK
13385 && SYMBOL_CLASS (sym) != LOC_CONST
13386 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13387 && type_name != NULL && strcmp (type_name, "exception") == 0);
13388}
13389
13390/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13391 Ada exception object. This matches all exceptions except the ones
13392 defined by the Ada language. */
13393
13394static int
13395ada_is_non_standard_exception_sym (struct symbol *sym)
13396{
13397 int i;
13398
13399 if (!ada_is_exception_sym (sym))
13400 return 0;
13401
13402 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13403 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13404 return 0; /* A standard exception. */
13405
13406 /* Numeric_Error is also a standard exception, so exclude it.
13407 See the STANDARD_EXC description for more details as to why
13408 this exception is not listed in that array. */
13409 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13410 return 0;
13411
13412 return 1;
13413}
13414
ab816a27 13415/* A helper function for std::sort, comparing two struct ada_exc_info
778865d3
JB
13416 objects.
13417
13418 The comparison is determined first by exception name, and then
13419 by exception address. */
13420
ab816a27 13421bool
cc536b21 13422ada_exc_info::operator< (const ada_exc_info &other) const
778865d3 13423{
778865d3
JB
13424 int result;
13425
ab816a27
TT
13426 result = strcmp (name, other.name);
13427 if (result < 0)
13428 return true;
13429 if (result == 0 && addr < other.addr)
13430 return true;
13431 return false;
13432}
778865d3 13433
ab816a27 13434bool
cc536b21 13435ada_exc_info::operator== (const ada_exc_info &other) const
ab816a27
TT
13436{
13437 return addr == other.addr && strcmp (name, other.name) == 0;
778865d3
JB
13438}
13439
13440/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13441 routine, but keeping the first SKIP elements untouched.
13442
13443 All duplicates are also removed. */
13444
13445static void
ab816a27 13446sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
778865d3
JB
13447 int skip)
13448{
ab816a27
TT
13449 std::sort (exceptions->begin () + skip, exceptions->end ());
13450 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13451 exceptions->end ());
778865d3
JB
13452}
13453
778865d3
JB
13454/* Add all exceptions defined by the Ada standard whose name match
13455 a regular expression.
13456
13457 If PREG is not NULL, then this regexp_t object is used to
13458 perform the symbol name matching. Otherwise, no name-based
13459 filtering is performed.
13460
13461 EXCEPTIONS is a vector of exceptions to which matching exceptions
13462 gets pushed. */
13463
13464static void
2d7cc5c7 13465ada_add_standard_exceptions (compiled_regex *preg,
ab816a27 13466 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13467{
13468 int i;
13469
13470 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13471 {
13472 if (preg == NULL
2d7cc5c7 13473 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13474 {
13475 struct bound_minimal_symbol msymbol
13476 = ada_lookup_simple_minsym (standard_exc[i]);
13477
13478 if (msymbol.minsym != NULL)
13479 {
13480 struct ada_exc_info info
77e371c0 13481 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3 13482
ab816a27 13483 exceptions->push_back (info);
778865d3
JB
13484 }
13485 }
13486 }
13487}
13488
13489/* Add all Ada exceptions defined locally and accessible from the given
13490 FRAME.
13491
13492 If PREG is not NULL, then this regexp_t object is used to
13493 perform the symbol name matching. Otherwise, no name-based
13494 filtering is performed.
13495
13496 EXCEPTIONS is a vector of exceptions to which matching exceptions
13497 gets pushed. */
13498
13499static void
2d7cc5c7
PA
13500ada_add_exceptions_from_frame (compiled_regex *preg,
13501 struct frame_info *frame,
ab816a27 13502 std::vector<ada_exc_info> *exceptions)
778865d3 13503{
3977b71f 13504 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13505
13506 while (block != 0)
13507 {
13508 struct block_iterator iter;
13509 struct symbol *sym;
13510
13511 ALL_BLOCK_SYMBOLS (block, iter, sym)
13512 {
13513 switch (SYMBOL_CLASS (sym))
13514 {
13515 case LOC_TYPEDEF:
13516 case LOC_BLOCK:
13517 case LOC_CONST:
13518 break;
13519 default:
13520 if (ada_is_exception_sym (sym))
13521 {
13522 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13523 SYMBOL_VALUE_ADDRESS (sym)};
13524
ab816a27 13525 exceptions->push_back (info);
778865d3
JB
13526 }
13527 }
13528 }
13529 if (BLOCK_FUNCTION (block) != NULL)
13530 break;
13531 block = BLOCK_SUPERBLOCK (block);
13532 }
13533}
13534
14bc53a8
PA
13535/* Return true if NAME matches PREG or if PREG is NULL. */
13536
13537static bool
2d7cc5c7 13538name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13539{
13540 return (preg == NULL
2d7cc5c7 13541 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13542}
13543
778865d3
JB
13544/* Add all exceptions defined globally whose name name match
13545 a regular expression, excluding standard exceptions.
13546
13547 The reason we exclude standard exceptions is that they need
13548 to be handled separately: Standard exceptions are defined inside
13549 a runtime unit which is normally not compiled with debugging info,
13550 and thus usually do not show up in our symbol search. However,
13551 if the unit was in fact built with debugging info, we need to
13552 exclude them because they would duplicate the entry we found
13553 during the special loop that specifically searches for those
13554 standard exceptions.
13555
13556 If PREG is not NULL, then this regexp_t object is used to
13557 perform the symbol name matching. Otherwise, no name-based
13558 filtering is performed.
13559
13560 EXCEPTIONS is a vector of exceptions to which matching exceptions
13561 gets pushed. */
13562
13563static void
2d7cc5c7 13564ada_add_global_exceptions (compiled_regex *preg,
ab816a27 13565 std::vector<ada_exc_info> *exceptions)
778865d3
JB
13566{
13567 struct objfile *objfile;
43f3e411 13568 struct compunit_symtab *s;
778865d3 13569
14bc53a8
PA
13570 /* In Ada, the symbol "search name" is a linkage name, whereas the
13571 regular expression used to do the matching refers to the natural
13572 name. So match against the decoded name. */
13573 expand_symtabs_matching (NULL,
b5ec771e 13574 lookup_name_info::match_any (),
14bc53a8
PA
13575 [&] (const char *search_name)
13576 {
13577 const char *decoded = ada_decode (search_name);
13578 return name_matches_regex (decoded, preg);
13579 },
13580 NULL,
13581 VARIABLES_DOMAIN);
778865d3 13582
43f3e411 13583 ALL_COMPUNITS (objfile, s)
778865d3 13584 {
43f3e411 13585 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13586 int i;
13587
13588 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13589 {
13590 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13591 struct block_iterator iter;
13592 struct symbol *sym;
13593
13594 ALL_BLOCK_SYMBOLS (b, iter, sym)
13595 if (ada_is_non_standard_exception_sym (sym)
14bc53a8 13596 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
778865d3
JB
13597 {
13598 struct ada_exc_info info
13599 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13600
ab816a27 13601 exceptions->push_back (info);
778865d3
JB
13602 }
13603 }
13604 }
13605}
13606
13607/* Implements ada_exceptions_list with the regular expression passed
13608 as a regex_t, rather than a string.
13609
13610 If not NULL, PREG is used to filter out exceptions whose names
13611 do not match. Otherwise, all exceptions are listed. */
13612
ab816a27 13613static std::vector<ada_exc_info>
2d7cc5c7 13614ada_exceptions_list_1 (compiled_regex *preg)
778865d3 13615{
ab816a27 13616 std::vector<ada_exc_info> result;
778865d3
JB
13617 int prev_len;
13618
13619 /* First, list the known standard exceptions. These exceptions
13620 need to be handled separately, as they are usually defined in
13621 runtime units that have been compiled without debugging info. */
13622
13623 ada_add_standard_exceptions (preg, &result);
13624
13625 /* Next, find all exceptions whose scope is local and accessible
13626 from the currently selected frame. */
13627
13628 if (has_stack_frames ())
13629 {
ab816a27 13630 prev_len = result.size ();
778865d3
JB
13631 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13632 &result);
ab816a27 13633 if (result.size () > prev_len)
778865d3
JB
13634 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13635 }
13636
13637 /* Add all exceptions whose scope is global. */
13638
ab816a27 13639 prev_len = result.size ();
778865d3 13640 ada_add_global_exceptions (preg, &result);
ab816a27 13641 if (result.size () > prev_len)
778865d3
JB
13642 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13643
778865d3
JB
13644 return result;
13645}
13646
13647/* Return a vector of ada_exc_info.
13648
13649 If REGEXP is NULL, all exceptions are included in the result.
13650 Otherwise, it should contain a valid regular expression,
13651 and only the exceptions whose names match that regular expression
13652 are included in the result.
13653
13654 The exceptions are sorted in the following order:
13655 - Standard exceptions (defined by the Ada language), in
13656 alphabetical order;
13657 - Exceptions only visible from the current frame, in
13658 alphabetical order;
13659 - Exceptions whose scope is global, in alphabetical order. */
13660
ab816a27 13661std::vector<ada_exc_info>
778865d3
JB
13662ada_exceptions_list (const char *regexp)
13663{
2d7cc5c7
PA
13664 if (regexp == NULL)
13665 return ada_exceptions_list_1 (NULL);
778865d3 13666
2d7cc5c7
PA
13667 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13668 return ada_exceptions_list_1 (&reg);
778865d3
JB
13669}
13670
13671/* Implement the "info exceptions" command. */
13672
13673static void
1d12d88f 13674info_exceptions_command (const char *regexp, int from_tty)
778865d3 13675{
778865d3 13676 struct gdbarch *gdbarch = get_current_arch ();
778865d3 13677
ab816a27 13678 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
778865d3
JB
13679
13680 if (regexp != NULL)
13681 printf_filtered
13682 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13683 else
13684 printf_filtered (_("All defined Ada exceptions:\n"));
13685
ab816a27
TT
13686 for (const ada_exc_info &info : exceptions)
13687 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
778865d3
JB
13688}
13689
4c4b4cd2
PH
13690 /* Operators */
13691/* Information about operators given special treatment in functions
13692 below. */
13693/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13694
13695#define ADA_OPERATORS \
13696 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13697 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13698 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13699 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13700 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13701 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13702 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13703 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13704 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13705 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13706 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13707 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13708 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13709 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13710 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13711 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13712 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13713 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13714 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13715
13716static void
554794dc
SDJ
13717ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13718 int *argsp)
4c4b4cd2
PH
13719{
13720 switch (exp->elts[pc - 1].opcode)
13721 {
76a01679 13722 default:
4c4b4cd2
PH
13723 operator_length_standard (exp, pc, oplenp, argsp);
13724 break;
13725
13726#define OP_DEFN(op, len, args, binop) \
13727 case op: *oplenp = len; *argsp = args; break;
13728 ADA_OPERATORS;
13729#undef OP_DEFN
52ce6436
PH
13730
13731 case OP_AGGREGATE:
13732 *oplenp = 3;
13733 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13734 break;
13735
13736 case OP_CHOICES:
13737 *oplenp = 3;
13738 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13739 break;
4c4b4cd2
PH
13740 }
13741}
13742
c0201579
JK
13743/* Implementation of the exp_descriptor method operator_check. */
13744
13745static int
13746ada_operator_check (struct expression *exp, int pos,
13747 int (*objfile_func) (struct objfile *objfile, void *data),
13748 void *data)
13749{
13750 const union exp_element *const elts = exp->elts;
13751 struct type *type = NULL;
13752
13753 switch (elts[pos].opcode)
13754 {
13755 case UNOP_IN_RANGE:
13756 case UNOP_QUAL:
13757 type = elts[pos + 1].type;
13758 break;
13759
13760 default:
13761 return operator_check_standard (exp, pos, objfile_func, data);
13762 }
13763
13764 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13765
13766 if (type && TYPE_OBJFILE (type)
13767 && (*objfile_func) (TYPE_OBJFILE (type), data))
13768 return 1;
13769
13770 return 0;
13771}
13772
a121b7c1 13773static const char *
4c4b4cd2
PH
13774ada_op_name (enum exp_opcode opcode)
13775{
13776 switch (opcode)
13777 {
76a01679 13778 default:
4c4b4cd2 13779 return op_name_standard (opcode);
52ce6436 13780
4c4b4cd2
PH
13781#define OP_DEFN(op, len, args, binop) case op: return #op;
13782 ADA_OPERATORS;
13783#undef OP_DEFN
52ce6436
PH
13784
13785 case OP_AGGREGATE:
13786 return "OP_AGGREGATE";
13787 case OP_CHOICES:
13788 return "OP_CHOICES";
13789 case OP_NAME:
13790 return "OP_NAME";
4c4b4cd2
PH
13791 }
13792}
13793
13794/* As for operator_length, but assumes PC is pointing at the first
13795 element of the operator, and gives meaningful results only for the
52ce6436 13796 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13797
13798static void
76a01679
JB
13799ada_forward_operator_length (struct expression *exp, int pc,
13800 int *oplenp, int *argsp)
4c4b4cd2 13801{
76a01679 13802 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13803 {
13804 default:
13805 *oplenp = *argsp = 0;
13806 break;
52ce6436 13807
4c4b4cd2
PH
13808#define OP_DEFN(op, len, args, binop) \
13809 case op: *oplenp = len; *argsp = args; break;
13810 ADA_OPERATORS;
13811#undef OP_DEFN
52ce6436
PH
13812
13813 case OP_AGGREGATE:
13814 *oplenp = 3;
13815 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13816 break;
13817
13818 case OP_CHOICES:
13819 *oplenp = 3;
13820 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13821 break;
13822
13823 case OP_STRING:
13824 case OP_NAME:
13825 {
13826 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13827
52ce6436
PH
13828 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13829 *argsp = 0;
13830 break;
13831 }
4c4b4cd2
PH
13832 }
13833}
13834
13835static int
13836ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13837{
13838 enum exp_opcode op = exp->elts[elt].opcode;
13839 int oplen, nargs;
13840 int pc = elt;
13841 int i;
76a01679 13842
4c4b4cd2
PH
13843 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13844
76a01679 13845 switch (op)
4c4b4cd2 13846 {
76a01679 13847 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13848 case OP_ATR_FIRST:
13849 case OP_ATR_LAST:
13850 case OP_ATR_LENGTH:
13851 case OP_ATR_IMAGE:
13852 case OP_ATR_MAX:
13853 case OP_ATR_MIN:
13854 case OP_ATR_MODULUS:
13855 case OP_ATR_POS:
13856 case OP_ATR_SIZE:
13857 case OP_ATR_TAG:
13858 case OP_ATR_VAL:
13859 break;
13860
13861 case UNOP_IN_RANGE:
13862 case UNOP_QUAL:
323e0a4a
AC
13863 /* XXX: gdb_sprint_host_address, type_sprint */
13864 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13865 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13866 fprintf_filtered (stream, " (");
13867 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13868 fprintf_filtered (stream, ")");
13869 break;
13870 case BINOP_IN_BOUNDS:
52ce6436
PH
13871 fprintf_filtered (stream, " (%d)",
13872 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13873 break;
13874 case TERNOP_IN_RANGE:
13875 break;
13876
52ce6436
PH
13877 case OP_AGGREGATE:
13878 case OP_OTHERS:
13879 case OP_DISCRETE_RANGE:
13880 case OP_POSITIONAL:
13881 case OP_CHOICES:
13882 break;
13883
13884 case OP_NAME:
13885 case OP_STRING:
13886 {
13887 char *name = &exp->elts[elt + 2].string;
13888 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13889
52ce6436
PH
13890 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13891 break;
13892 }
13893
4c4b4cd2
PH
13894 default:
13895 return dump_subexp_body_standard (exp, stream, elt);
13896 }
13897
13898 elt += oplen;
13899 for (i = 0; i < nargs; i += 1)
13900 elt = dump_subexp (exp, stream, elt);
13901
13902 return elt;
13903}
13904
13905/* The Ada extension of print_subexp (q.v.). */
13906
76a01679
JB
13907static void
13908ada_print_subexp (struct expression *exp, int *pos,
13909 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13910{
52ce6436 13911 int oplen, nargs, i;
4c4b4cd2
PH
13912 int pc = *pos;
13913 enum exp_opcode op = exp->elts[pc].opcode;
13914
13915 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13916
52ce6436 13917 *pos += oplen;
4c4b4cd2
PH
13918 switch (op)
13919 {
13920 default:
52ce6436 13921 *pos -= oplen;
4c4b4cd2
PH
13922 print_subexp_standard (exp, pos, stream, prec);
13923 return;
13924
13925 case OP_VAR_VALUE:
4c4b4cd2
PH
13926 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13927 return;
13928
13929 case BINOP_IN_BOUNDS:
323e0a4a 13930 /* XXX: sprint_subexp */
4c4b4cd2 13931 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13932 fputs_filtered (" in ", stream);
4c4b4cd2 13933 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13934 fputs_filtered ("'range", stream);
4c4b4cd2 13935 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13936 fprintf_filtered (stream, "(%ld)",
13937 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13938 return;
13939
13940 case TERNOP_IN_RANGE:
4c4b4cd2 13941 if (prec >= PREC_EQUAL)
76a01679 13942 fputs_filtered ("(", stream);
323e0a4a 13943 /* XXX: sprint_subexp */
4c4b4cd2 13944 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13945 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13946 print_subexp (exp, pos, stream, PREC_EQUAL);
13947 fputs_filtered (" .. ", stream);
13948 print_subexp (exp, pos, stream, PREC_EQUAL);
13949 if (prec >= PREC_EQUAL)
76a01679
JB
13950 fputs_filtered (")", stream);
13951 return;
4c4b4cd2
PH
13952
13953 case OP_ATR_FIRST:
13954 case OP_ATR_LAST:
13955 case OP_ATR_LENGTH:
13956 case OP_ATR_IMAGE:
13957 case OP_ATR_MAX:
13958 case OP_ATR_MIN:
13959 case OP_ATR_MODULUS:
13960 case OP_ATR_POS:
13961 case OP_ATR_SIZE:
13962 case OP_ATR_TAG:
13963 case OP_ATR_VAL:
4c4b4cd2 13964 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13965 {
13966 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13967 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13968 &type_print_raw_options);
76a01679
JB
13969 *pos += 3;
13970 }
4c4b4cd2 13971 else
76a01679 13972 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13973 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13974 if (nargs > 1)
76a01679
JB
13975 {
13976 int tem;
5b4ee69b 13977
76a01679
JB
13978 for (tem = 1; tem < nargs; tem += 1)
13979 {
13980 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13981 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13982 }
13983 fputs_filtered (")", stream);
13984 }
4c4b4cd2 13985 return;
14f9c5c9 13986
4c4b4cd2 13987 case UNOP_QUAL:
4c4b4cd2
PH
13988 type_print (exp->elts[pc + 1].type, "", stream, 0);
13989 fputs_filtered ("'(", stream);
13990 print_subexp (exp, pos, stream, PREC_PREFIX);
13991 fputs_filtered (")", stream);
13992 return;
14f9c5c9 13993
4c4b4cd2 13994 case UNOP_IN_RANGE:
323e0a4a 13995 /* XXX: sprint_subexp */
4c4b4cd2 13996 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13997 fputs_filtered (" in ", stream);
79d43c61
TT
13998 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13999 &type_print_raw_options);
4c4b4cd2 14000 return;
52ce6436
PH
14001
14002 case OP_DISCRETE_RANGE:
14003 print_subexp (exp, pos, stream, PREC_SUFFIX);
14004 fputs_filtered ("..", stream);
14005 print_subexp (exp, pos, stream, PREC_SUFFIX);
14006 return;
14007
14008 case OP_OTHERS:
14009 fputs_filtered ("others => ", stream);
14010 print_subexp (exp, pos, stream, PREC_SUFFIX);
14011 return;
14012
14013 case OP_CHOICES:
14014 for (i = 0; i < nargs-1; i += 1)
14015 {
14016 if (i > 0)
14017 fputs_filtered ("|", stream);
14018 print_subexp (exp, pos, stream, PREC_SUFFIX);
14019 }
14020 fputs_filtered (" => ", stream);
14021 print_subexp (exp, pos, stream, PREC_SUFFIX);
14022 return;
14023
14024 case OP_POSITIONAL:
14025 print_subexp (exp, pos, stream, PREC_SUFFIX);
14026 return;
14027
14028 case OP_AGGREGATE:
14029 fputs_filtered ("(", stream);
14030 for (i = 0; i < nargs; i += 1)
14031 {
14032 if (i > 0)
14033 fputs_filtered (", ", stream);
14034 print_subexp (exp, pos, stream, PREC_SUFFIX);
14035 }
14036 fputs_filtered (")", stream);
14037 return;
4c4b4cd2
PH
14038 }
14039}
14f9c5c9
AS
14040
14041/* Table mapping opcodes into strings for printing operators
14042 and precedences of the operators. */
14043
d2e4a39e
AS
14044static const struct op_print ada_op_print_tab[] = {
14045 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14046 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14047 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14048 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14049 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14050 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14051 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14052 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14053 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14054 {">=", BINOP_GEQ, PREC_ORDER, 0},
14055 {">", BINOP_GTR, PREC_ORDER, 0},
14056 {"<", BINOP_LESS, PREC_ORDER, 0},
14057 {">>", BINOP_RSH, PREC_SHIFT, 0},
14058 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14059 {"+", BINOP_ADD, PREC_ADD, 0},
14060 {"-", BINOP_SUB, PREC_ADD, 0},
14061 {"&", BINOP_CONCAT, PREC_ADD, 0},
14062 {"*", BINOP_MUL, PREC_MUL, 0},
14063 {"/", BINOP_DIV, PREC_MUL, 0},
14064 {"rem", BINOP_REM, PREC_MUL, 0},
14065 {"mod", BINOP_MOD, PREC_MUL, 0},
14066 {"**", BINOP_EXP, PREC_REPEAT, 0},
14067 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14068 {"-", UNOP_NEG, PREC_PREFIX, 0},
14069 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14070 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14071 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14072 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
14073 {".all", UNOP_IND, PREC_SUFFIX, 1},
14074 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14075 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 14076 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
14077};
14078\f
72d5681a
PH
14079enum ada_primitive_types {
14080 ada_primitive_type_int,
14081 ada_primitive_type_long,
14082 ada_primitive_type_short,
14083 ada_primitive_type_char,
14084 ada_primitive_type_float,
14085 ada_primitive_type_double,
14086 ada_primitive_type_void,
14087 ada_primitive_type_long_long,
14088 ada_primitive_type_long_double,
14089 ada_primitive_type_natural,
14090 ada_primitive_type_positive,
14091 ada_primitive_type_system_address,
08f49010 14092 ada_primitive_type_storage_offset,
72d5681a
PH
14093 nr_ada_primitive_types
14094};
6c038f32
PH
14095
14096static void
d4a9a881 14097ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
14098 struct language_arch_info *lai)
14099{
d4a9a881 14100 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 14101
72d5681a 14102 lai->primitive_type_vector
d4a9a881 14103 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 14104 struct type *);
e9bb382b
UW
14105
14106 lai->primitive_type_vector [ada_primitive_type_int]
14107 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14108 0, "integer");
14109 lai->primitive_type_vector [ada_primitive_type_long]
14110 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14111 0, "long_integer");
14112 lai->primitive_type_vector [ada_primitive_type_short]
14113 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14114 0, "short_integer");
14115 lai->string_char_type
14116 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 14117 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
14118 lai->primitive_type_vector [ada_primitive_type_float]
14119 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 14120 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
14121 lai->primitive_type_vector [ada_primitive_type_double]
14122 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 14123 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
14124 lai->primitive_type_vector [ada_primitive_type_long_long]
14125 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14126 0, "long_long_integer");
14127 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 14128 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 14129 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
14130 lai->primitive_type_vector [ada_primitive_type_natural]
14131 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14132 0, "natural");
14133 lai->primitive_type_vector [ada_primitive_type_positive]
14134 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14135 0, "positive");
14136 lai->primitive_type_vector [ada_primitive_type_void]
14137 = builtin->builtin_void;
14138
14139 lai->primitive_type_vector [ada_primitive_type_system_address]
77b7c781
UW
14140 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14141 "void"));
72d5681a
PH
14142 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14143 = "system__address";
fbb06eb1 14144
08f49010
XR
14145 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14146 type. This is a signed integral type whose size is the same as
14147 the size of addresses. */
14148 {
14149 unsigned int addr_length = TYPE_LENGTH
14150 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14151
14152 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14153 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14154 "storage_offset");
14155 }
14156
47e729a8 14157 lai->bool_type_symbol = NULL;
fbb06eb1 14158 lai->bool_type_default = builtin->builtin_bool;
6c038f32 14159}
6c038f32
PH
14160\f
14161 /* Language vector */
14162
14163/* Not really used, but needed in the ada_language_defn. */
14164
14165static void
6c7a06a3 14166emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 14167{
6c7a06a3 14168 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
14169}
14170
14171static int
410a0ff2 14172parse (struct parser_state *ps)
6c038f32
PH
14173{
14174 warnings_issued = 0;
410a0ff2 14175 return ada_parse (ps);
6c038f32
PH
14176}
14177
14178static const struct exp_descriptor ada_exp_descriptor = {
14179 ada_print_subexp,
14180 ada_operator_length,
c0201579 14181 ada_operator_check,
6c038f32
PH
14182 ada_op_name,
14183 ada_dump_subexp_body,
14184 ada_evaluate_subexp
14185};
14186
b5ec771e
PA
14187/* symbol_name_matcher_ftype adapter for wild_match. */
14188
14189static bool
14190do_wild_match (const char *symbol_search_name,
14191 const lookup_name_info &lookup_name,
a207cff2 14192 completion_match_result *comp_match_res)
b5ec771e
PA
14193{
14194 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14195}
14196
14197/* symbol_name_matcher_ftype adapter for full_match. */
14198
14199static bool
14200do_full_match (const char *symbol_search_name,
14201 const lookup_name_info &lookup_name,
a207cff2 14202 completion_match_result *comp_match_res)
b5ec771e
PA
14203{
14204 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14205}
14206
14207/* Build the Ada lookup name for LOOKUP_NAME. */
14208
14209ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14210{
14211 const std::string &user_name = lookup_name.name ();
14212
14213 if (user_name[0] == '<')
14214 {
14215 if (user_name.back () == '>')
14216 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14217 else
14218 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14219 m_encoded_p = true;
14220 m_verbatim_p = true;
14221 m_wild_match_p = false;
14222 m_standard_p = false;
14223 }
14224 else
14225 {
14226 m_verbatim_p = false;
14227
14228 m_encoded_p = user_name.find ("__") != std::string::npos;
14229
14230 if (!m_encoded_p)
14231 {
14232 const char *folded = ada_fold_name (user_name.c_str ());
14233 const char *encoded = ada_encode_1 (folded, false);
14234 if (encoded != NULL)
14235 m_encoded_name = encoded;
14236 else
14237 m_encoded_name = user_name;
14238 }
14239 else
14240 m_encoded_name = user_name;
14241
14242 /* Handle the 'package Standard' special case. See description
14243 of m_standard_p. */
14244 if (startswith (m_encoded_name.c_str (), "standard__"))
14245 {
14246 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14247 m_standard_p = true;
14248 }
14249 else
14250 m_standard_p = false;
74ccd7f5 14251
b5ec771e
PA
14252 /* If the name contains a ".", then the user is entering a fully
14253 qualified entity name, and the match must not be done in wild
14254 mode. Similarly, if the user wants to complete what looks
14255 like an encoded name, the match must not be done in wild
14256 mode. Also, in the standard__ special case always do
14257 non-wild matching. */
14258 m_wild_match_p
14259 = (lookup_name.match_type () != symbol_name_match_type::FULL
14260 && !m_encoded_p
14261 && !m_standard_p
14262 && user_name.find ('.') == std::string::npos);
14263 }
14264}
14265
14266/* symbol_name_matcher_ftype method for Ada. This only handles
14267 completion mode. */
14268
14269static bool
14270ada_symbol_name_matches (const char *symbol_search_name,
14271 const lookup_name_info &lookup_name,
a207cff2 14272 completion_match_result *comp_match_res)
74ccd7f5 14273{
b5ec771e
PA
14274 return lookup_name.ada ().matches (symbol_search_name,
14275 lookup_name.match_type (),
a207cff2 14276 comp_match_res);
b5ec771e
PA
14277}
14278
de63c46b
PA
14279/* A name matcher that matches the symbol name exactly, with
14280 strcmp. */
14281
14282static bool
14283literal_symbol_name_matcher (const char *symbol_search_name,
14284 const lookup_name_info &lookup_name,
14285 completion_match_result *comp_match_res)
14286{
14287 const std::string &name = lookup_name.name ();
14288
14289 int cmp = (lookup_name.completion_mode ()
14290 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14291 : strcmp (symbol_search_name, name.c_str ()));
14292 if (cmp == 0)
14293 {
14294 if (comp_match_res != NULL)
14295 comp_match_res->set_match (symbol_search_name);
14296 return true;
14297 }
14298 else
14299 return false;
14300}
14301
b5ec771e
PA
14302/* Implement the "la_get_symbol_name_matcher" language_defn method for
14303 Ada. */
14304
14305static symbol_name_matcher_ftype *
14306ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14307{
de63c46b
PA
14308 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14309 return literal_symbol_name_matcher;
14310
b5ec771e
PA
14311 if (lookup_name.completion_mode ())
14312 return ada_symbol_name_matches;
74ccd7f5 14313 else
b5ec771e
PA
14314 {
14315 if (lookup_name.ada ().wild_match_p ())
14316 return do_wild_match;
14317 else
14318 return do_full_match;
14319 }
74ccd7f5
JB
14320}
14321
a5ee536b
JB
14322/* Implement the "la_read_var_value" language_defn method for Ada. */
14323
14324static struct value *
63e43d3a
PMR
14325ada_read_var_value (struct symbol *var, const struct block *var_block,
14326 struct frame_info *frame)
a5ee536b 14327{
3977b71f 14328 const struct block *frame_block = NULL;
a5ee536b
JB
14329 struct symbol *renaming_sym = NULL;
14330
14331 /* The only case where default_read_var_value is not sufficient
14332 is when VAR is a renaming... */
14333 if (frame)
14334 frame_block = get_frame_block (frame, NULL);
14335 if (frame_block)
14336 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14337 if (renaming_sym != NULL)
14338 return ada_read_renaming_var_value (renaming_sym, frame_block);
14339
14340 /* This is a typical case where we expect the default_read_var_value
14341 function to work. */
63e43d3a 14342 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
14343}
14344
56618e20
TT
14345static const char *ada_extensions[] =
14346{
14347 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14348};
14349
47e77640 14350extern const struct language_defn ada_language_defn = {
6c038f32 14351 "ada", /* Language name */
6abde28f 14352 "Ada",
6c038f32 14353 language_ada,
6c038f32 14354 range_check_off,
6c038f32
PH
14355 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14356 that's not quite what this means. */
6c038f32 14357 array_row_major,
9a044a89 14358 macro_expansion_no,
56618e20 14359 ada_extensions,
6c038f32
PH
14360 &ada_exp_descriptor,
14361 parse,
6c038f32
PH
14362 resolve,
14363 ada_printchar, /* Print a character constant */
14364 ada_printstr, /* Function to print string constant */
14365 emit_char, /* Function to print single char (not used) */
6c038f32 14366 ada_print_type, /* Print a type using appropriate syntax */
be942545 14367 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
14368 ada_val_print, /* Print a value using appropriate syntax */
14369 ada_value_print, /* Print a top-level value */
a5ee536b 14370 ada_read_var_value, /* la_read_var_value */
6c038f32 14371 NULL, /* Language specific skip_trampoline */
2b2d9e11 14372 NULL, /* name_of_this */
59cc4834 14373 true, /* la_store_sym_names_in_linkage_form_p */
6c038f32
PH
14374 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14375 basic_lookup_transparent_type, /* lookup_transparent_type */
14376 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14377 ada_sniff_from_mangled_name,
0963b4bd
MS
14378 NULL, /* Language specific
14379 class_name_from_physname */
6c038f32
PH
14380 ada_op_print_tab, /* expression operators for printing */
14381 0, /* c-style arrays */
14382 1, /* String lower bound */
6c038f32 14383 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 14384 ada_collect_symbol_completion_matches,
72d5681a 14385 ada_language_arch_info,
e79af960 14386 ada_print_array_index,
41f1b697 14387 default_pass_by_reference,
ae6a3a4c 14388 c_get_string,
43cc5389 14389 c_watch_location_expression,
b5ec771e 14390 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 14391 ada_iterate_over_symbols,
5ffa0793 14392 default_search_name_hash,
a53b64ea 14393 &ada_varobj_ops,
bb2ec1b3
TT
14394 NULL,
14395 NULL,
6c038f32
PH
14396 LANG_MAGIC
14397};
14398
5bf03f13
JB
14399/* Command-list for the "set/show ada" prefix command. */
14400static struct cmd_list_element *set_ada_list;
14401static struct cmd_list_element *show_ada_list;
14402
14403/* Implement the "set ada" prefix command. */
14404
14405static void
981a3fb3 14406set_ada_command (const char *arg, int from_tty)
5bf03f13
JB
14407{
14408 printf_unfiltered (_(\
14409"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14410 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14411}
14412
14413/* Implement the "show ada" prefix command. */
14414
14415static void
981a3fb3 14416show_ada_command (const char *args, int from_tty)
5bf03f13
JB
14417{
14418 cmd_show_list (show_ada_list, from_tty, "");
14419}
14420
2060206e
PA
14421static void
14422initialize_ada_catchpoint_ops (void)
14423{
14424 struct breakpoint_ops *ops;
14425
14426 initialize_breakpoint_ops ();
14427
14428 ops = &catch_exception_breakpoint_ops;
14429 *ops = bkpt_breakpoint_ops;
2060206e
PA
14430 ops->allocate_location = allocate_location_catch_exception;
14431 ops->re_set = re_set_catch_exception;
14432 ops->check_status = check_status_catch_exception;
14433 ops->print_it = print_it_catch_exception;
14434 ops->print_one = print_one_catch_exception;
14435 ops->print_mention = print_mention_catch_exception;
14436 ops->print_recreate = print_recreate_catch_exception;
14437
14438 ops = &catch_exception_unhandled_breakpoint_ops;
14439 *ops = bkpt_breakpoint_ops;
2060206e
PA
14440 ops->allocate_location = allocate_location_catch_exception_unhandled;
14441 ops->re_set = re_set_catch_exception_unhandled;
14442 ops->check_status = check_status_catch_exception_unhandled;
14443 ops->print_it = print_it_catch_exception_unhandled;
14444 ops->print_one = print_one_catch_exception_unhandled;
14445 ops->print_mention = print_mention_catch_exception_unhandled;
14446 ops->print_recreate = print_recreate_catch_exception_unhandled;
14447
14448 ops = &catch_assert_breakpoint_ops;
14449 *ops = bkpt_breakpoint_ops;
2060206e
PA
14450 ops->allocate_location = allocate_location_catch_assert;
14451 ops->re_set = re_set_catch_assert;
14452 ops->check_status = check_status_catch_assert;
14453 ops->print_it = print_it_catch_assert;
14454 ops->print_one = print_one_catch_assert;
14455 ops->print_mention = print_mention_catch_assert;
14456 ops->print_recreate = print_recreate_catch_assert;
9f757bf7
XR
14457
14458 ops = &catch_handlers_breakpoint_ops;
14459 *ops = bkpt_breakpoint_ops;
14460 ops->allocate_location = allocate_location_catch_handlers;
14461 ops->re_set = re_set_catch_handlers;
14462 ops->check_status = check_status_catch_handlers;
14463 ops->print_it = print_it_catch_handlers;
14464 ops->print_one = print_one_catch_handlers;
14465 ops->print_mention = print_mention_catch_handlers;
14466 ops->print_recreate = print_recreate_catch_handlers;
2060206e
PA
14467}
14468
3d9434b5
JB
14469/* This module's 'new_objfile' observer. */
14470
14471static void
14472ada_new_objfile_observer (struct objfile *objfile)
14473{
14474 ada_clear_symbol_cache ();
14475}
14476
14477/* This module's 'free_objfile' observer. */
14478
14479static void
14480ada_free_objfile_observer (struct objfile *objfile)
14481{
14482 ada_clear_symbol_cache ();
14483}
14484
d2e4a39e 14485void
6c038f32 14486_initialize_ada_language (void)
14f9c5c9 14487{
2060206e
PA
14488 initialize_ada_catchpoint_ops ();
14489
5bf03f13
JB
14490 add_prefix_cmd ("ada", no_class, set_ada_command,
14491 _("Prefix command for changing Ada-specfic settings"),
14492 &set_ada_list, "set ada ", 0, &setlist);
14493
14494 add_prefix_cmd ("ada", no_class, show_ada_command,
14495 _("Generic command for showing Ada-specific settings."),
14496 &show_ada_list, "show ada ", 0, &showlist);
14497
14498 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14499 &trust_pad_over_xvs, _("\
14500Enable or disable an optimization trusting PAD types over XVS types"), _("\
14501Show whether an optimization trusting PAD types over XVS types is activated"),
14502 _("\
14503This is related to the encoding used by the GNAT compiler. The debugger\n\
14504should normally trust the contents of PAD types, but certain older versions\n\
14505of GNAT have a bug that sometimes causes the information in the PAD type\n\
14506to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14507work around this bug. It is always safe to turn this option \"off\", but\n\
14508this incurs a slight performance penalty, so it is recommended to NOT change\n\
14509this option to \"off\" unless necessary."),
14510 NULL, NULL, &set_ada_list, &show_ada_list);
14511
d72413e6
PMR
14512 add_setshow_boolean_cmd ("print-signatures", class_vars,
14513 &print_signatures, _("\
14514Enable or disable the output of formal and return types for functions in the \
14515overloads selection menu"), _("\
14516Show whether the output of formal and return types for functions in the \
14517overloads selection menu is activated"),
14518 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14519
9ac4176b
PA
14520 add_catch_command ("exception", _("\
14521Catch Ada exceptions, when raised.\n\
14522With an argument, catch only exceptions with the given name."),
14523 catch_ada_exception_command,
14524 NULL,
14525 CATCH_PERMANENT,
14526 CATCH_TEMPORARY);
9f757bf7
XR
14527
14528 add_catch_command ("handlers", _("\
14529Catch Ada exceptions, when handled.\n\
14530With an argument, catch only exceptions with the given name."),
14531 catch_ada_handlers_command,
14532 NULL,
14533 CATCH_PERMANENT,
14534 CATCH_TEMPORARY);
9ac4176b
PA
14535 add_catch_command ("assert", _("\
14536Catch failed Ada assertions, when raised.\n\
14537With an argument, catch only exceptions with the given name."),
14538 catch_assert_command,
14539 NULL,
14540 CATCH_PERMANENT,
14541 CATCH_TEMPORARY);
14542
6c038f32 14543 varsize_limit = 65536;
3fcded8f
JB
14544 add_setshow_uinteger_cmd ("varsize-limit", class_support,
14545 &varsize_limit, _("\
14546Set the maximum number of bytes allowed in a variable-size object."), _("\
14547Show the maximum number of bytes allowed in a variable-size object."), _("\
14548Attempts to access an object whose size is not a compile-time constant\n\
14549and exceeds this limit will cause an error."),
14550 NULL, NULL, &setlist, &showlist);
6c038f32 14551
778865d3
JB
14552 add_info ("exceptions", info_exceptions_command,
14553 _("\
14554List all Ada exception names.\n\
14555If a regular expression is passed as an argument, only those matching\n\
14556the regular expression are listed."));
14557
c6044dd1
JB
14558 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14559 _("Set Ada maintenance-related variables."),
14560 &maint_set_ada_cmdlist, "maintenance set ada ",
14561 0/*allow-unknown*/, &maintenance_set_cmdlist);
14562
14563 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14564 _("Show Ada maintenance-related variables"),
14565 &maint_show_ada_cmdlist, "maintenance show ada ",
14566 0/*allow-unknown*/, &maintenance_show_cmdlist);
14567
14568 add_setshow_boolean_cmd
14569 ("ignore-descriptive-types", class_maintenance,
14570 &ada_ignore_descriptive_types_p,
14571 _("Set whether descriptive types generated by GNAT should be ignored."),
14572 _("Show whether descriptive types generated by GNAT should be ignored."),
14573 _("\
14574When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14575DWARF attribute."),
14576 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14577
459a2e4c
TT
14578 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash,
14579 NULL, xcalloc, xfree);
6b69afc4 14580
3d9434b5 14581 /* The ada-lang observers. */
76727919
TT
14582 gdb::observers::new_objfile.attach (ada_new_objfile_observer);
14583 gdb::observers::free_objfile.attach (ada_free_objfile_observer);
14584 gdb::observers::inferior_exit.attach (ada_inferior_exit);
ee01b665
JB
14585
14586 /* Setup various context-specific data. */
e802dbe0 14587 ada_inferior_data
8e260fc0 14588 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14589 ada_pspace_data_handle
14590 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14591}