]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
(Ada) Fix -var-list-children MI command for union type
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
e2882c85 3 Copyright (C) 1992-2018 Free Software Foundation, Inc.
14f9c5c9 4
a9762ec7 5 This file is part of GDB.
14f9c5c9 6
a9762ec7
JB
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
14f9c5c9 11
a9762ec7
JB
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
14f9c5c9 16
a9762ec7
JB
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
14f9c5c9 19
96d887e8 20
4c4b4cd2 21#include "defs.h"
14f9c5c9 22#include <ctype.h>
14f9c5c9 23#include "demangle.h"
4c4b4cd2
PH
24#include "gdb_regex.h"
25#include "frame.h"
14f9c5c9
AS
26#include "symtab.h"
27#include "gdbtypes.h"
28#include "gdbcmd.h"
29#include "expression.h"
30#include "parser-defs.h"
31#include "language.h"
a53b64ea 32#include "varobj.h"
14f9c5c9
AS
33#include "c-lang.h"
34#include "inferior.h"
35#include "symfile.h"
36#include "objfiles.h"
37#include "breakpoint.h"
38#include "gdbcore.h"
4c4b4cd2
PH
39#include "hashtab.h"
40#include "gdb_obstack.h"
14f9c5c9 41#include "ada-lang.h"
4c4b4cd2 42#include "completer.h"
53ce3c39 43#include <sys/stat.h>
14f9c5c9 44#include "ui-out.h"
fe898f56 45#include "block.h"
04714b91 46#include "infcall.h"
de4f826b 47#include "dictionary.h"
f7f9143b
JB
48#include "annotate.h"
49#include "valprint.h"
9bbc9174 50#include "source.h"
76727919 51#include "observable.h"
2ba95b9b 52#include "vec.h"
692465f1 53#include "stack.h"
fa864999 54#include "gdb_vecs.h"
79d43c61 55#include "typeprint.h"
22cee43f 56#include "namespace.h"
14f9c5c9 57
ccefe4c4 58#include "psymtab.h"
40bc484c 59#include "value.h"
956a9fb9 60#include "mi/mi-common.h"
9ac4176b 61#include "arch-utils.h"
0fcd72ba 62#include "cli/cli-utils.h"
14bc53a8 63#include "common/function-view.h"
d5722aa2 64#include "common/byte-vector.h"
ab816a27 65#include <algorithm>
ccefe4c4 66
4c4b4cd2 67/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 68 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
69 Copied from valarith.c. */
70
71#ifndef TRUNCATION_TOWARDS_ZERO
72#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73#endif
74
d2e4a39e 75static struct type *desc_base_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct type *desc_bounds_type (struct type *);
14f9c5c9 78
d2e4a39e 79static struct value *desc_bounds (struct value *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 82
d2e4a39e 83static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 84
556bdfd4 85static struct type *desc_data_target_type (struct type *);
14f9c5c9 86
d2e4a39e 87static struct value *desc_data (struct value *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 90
d2e4a39e 91static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 92
d2e4a39e 93static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 98
d2e4a39e 99static struct type *desc_index_type (struct type *, int);
14f9c5c9 100
d2e4a39e 101static int desc_arity (struct type *);
14f9c5c9 102
d2e4a39e 103static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 104
d2e4a39e 105static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 106
40bc484c 107static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 108
4c4b4cd2 109static void ada_add_block_symbols (struct obstack *,
b5ec771e
PA
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
14f9c5c9 113
22cee43f 114static void ada_add_all_symbols (struct obstack *, const struct block *,
b5ec771e
PA
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
22cee43f 117
d12307c1 118static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 119
76a01679 120static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 121 const struct block *);
14f9c5c9 122
4c4b4cd2
PH
123static int num_defns_collected (struct obstack *);
124
d12307c1 125static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 126
e9d9f57e 127static struct value *resolve_subexp (expression_up *, int *, int,
76a01679 128 struct type *);
14f9c5c9 129
e9d9f57e 130static void replace_operator_with_call (expression_up *, int, int, int,
270140bd 131 struct symbol *, const struct block *);
14f9c5c9 132
d2e4a39e 133static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 134
a121b7c1 135static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
136
137static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 138
d2e4a39e 139static int numeric_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int integer_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int scalar_type_p (struct type *);
14f9c5c9 144
d2e4a39e 145static int discrete_type_p (struct type *);
14f9c5c9 146
aeb5907d
JB
147static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 153 const struct block *);
aeb5907d 154
a121b7c1 155static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 156 int, int);
4c4b4cd2 157
d2e4a39e 158static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 159
b4ba55a1
JB
160static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
d2e4a39e 163static int is_dynamic_field (struct type *, int);
14f9c5c9 164
10a2c479 165static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 166 const gdb_byte *,
4c4b4cd2
PH
167 CORE_ADDR, struct value *);
168
169static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 170
28c85d6c 171static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 172
d2e4a39e 173static struct type *to_static_fixed_type (struct type *);
f192137b 174static struct type *static_unwrap_type (struct type *type);
14f9c5c9 175
d2e4a39e 176static struct value *unwrap_value (struct value *);
14f9c5c9 177
ad82864c 178static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 179
ad82864c 180static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 181
ad82864c
JB
182static long decode_packed_array_bitsize (struct type *);
183
184static struct value *decode_constrained_packed_array (struct value *);
185
186static int ada_is_packed_array_type (struct type *);
187
188static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 189
d2e4a39e 190static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 191 struct value **);
14f9c5c9 192
50810684 193static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 194
4c4b4cd2
PH
195static struct value *coerce_unspec_val_to_type (struct value *,
196 struct type *);
14f9c5c9 197
d2e4a39e 198static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 199
d2e4a39e 200static int equiv_types (struct type *, struct type *);
14f9c5c9 201
d2e4a39e 202static int is_name_suffix (const char *);
14f9c5c9 203
73589123
PH
204static int advance_wild_match (const char **, const char *, int);
205
b5ec771e 206static bool wild_match (const char *name, const char *patn);
14f9c5c9 207
d2e4a39e 208static struct value *ada_coerce_ref (struct value *);
14f9c5c9 209
4c4b4cd2
PH
210static LONGEST pos_atr (struct value *);
211
3cb382c9 212static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 213
d2e4a39e 214static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 215
4c4b4cd2
PH
216static struct symbol *standard_lookup (const char *, const struct block *,
217 domain_enum);
14f9c5c9 218
108d56a4 219static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
220 struct type *);
221
222static struct value *ada_value_primitive_field (struct value *, int, int,
223 struct type *);
224
0d5cff50 225static int find_struct_field (const char *, struct type *, int,
52ce6436 226 struct type **, int *, int *, int *, int *);
4c4b4cd2 227
d12307c1 228static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
229 struct value **, int, const char *,
230 struct type *);
231
4c4b4cd2
PH
232static int ada_is_direct_array_type (struct type *);
233
72d5681a
PH
234static void ada_language_arch_info (struct gdbarch *,
235 struct language_arch_info *);
714e53ab 236
52ce6436
PH
237static struct value *ada_index_struct_field (int, struct value *, int,
238 struct type *);
239
240static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
241 struct expression *,
242 int *, enum noside);
52ce6436
PH
243
244static void aggregate_assign_from_choices (struct value *, struct value *,
245 struct expression *,
246 int *, LONGEST *, int *,
247 int, LONGEST, LONGEST);
248
249static void aggregate_assign_positional (struct value *, struct value *,
250 struct expression *,
251 int *, LONGEST *, int *, int,
252 LONGEST, LONGEST);
253
254
255static void aggregate_assign_others (struct value *, struct value *,
256 struct expression *,
257 int *, LONGEST *, int, LONGEST, LONGEST);
258
259
260static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
261
262
263static struct value *ada_evaluate_subexp (struct type *, struct expression *,
264 int *, enum noside);
265
266static void ada_forward_operator_length (struct expression *, int, int *,
267 int *);
852dff6c
JB
268
269static struct type *ada_find_any_type (const char *name);
b5ec771e
PA
270
271static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
272 (const lookup_name_info &lookup_name);
273
4c4b4cd2
PH
274\f
275
ee01b665
JB
276/* The result of a symbol lookup to be stored in our symbol cache. */
277
278struct cache_entry
279{
280 /* The name used to perform the lookup. */
281 const char *name;
282 /* The namespace used during the lookup. */
fe978cb0 283 domain_enum domain;
ee01b665
JB
284 /* The symbol returned by the lookup, or NULL if no matching symbol
285 was found. */
286 struct symbol *sym;
287 /* The block where the symbol was found, or NULL if no matching
288 symbol was found. */
289 const struct block *block;
290 /* A pointer to the next entry with the same hash. */
291 struct cache_entry *next;
292};
293
294/* The Ada symbol cache, used to store the result of Ada-mode symbol
295 lookups in the course of executing the user's commands.
296
297 The cache is implemented using a simple, fixed-sized hash.
298 The size is fixed on the grounds that there are not likely to be
299 all that many symbols looked up during any given session, regardless
300 of the size of the symbol table. If we decide to go to a resizable
301 table, let's just use the stuff from libiberty instead. */
302
303#define HASH_SIZE 1009
304
305struct ada_symbol_cache
306{
307 /* An obstack used to store the entries in our cache. */
308 struct obstack cache_space;
309
310 /* The root of the hash table used to implement our symbol cache. */
311 struct cache_entry *root[HASH_SIZE];
312};
313
314static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 315
4c4b4cd2 316/* Maximum-sized dynamic type. */
14f9c5c9
AS
317static unsigned int varsize_limit;
318
67cb5b2d 319static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
320#ifdef VMS
321 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
322#else
14f9c5c9 323 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 324#endif
14f9c5c9 325
4c4b4cd2 326/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 327static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 328 = "__gnat_ada_main_program_name";
14f9c5c9 329
4c4b4cd2
PH
330/* Limit on the number of warnings to raise per expression evaluation. */
331static int warning_limit = 2;
332
333/* Number of warning messages issued; reset to 0 by cleanups after
334 expression evaluation. */
335static int warnings_issued = 0;
336
337static const char *known_runtime_file_name_patterns[] = {
338 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
339};
340
341static const char *known_auxiliary_function_name_patterns[] = {
342 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
343};
344
c6044dd1
JB
345/* Maintenance-related settings for this module. */
346
347static struct cmd_list_element *maint_set_ada_cmdlist;
348static struct cmd_list_element *maint_show_ada_cmdlist;
349
350/* Implement the "maintenance set ada" (prefix) command. */
351
352static void
981a3fb3 353maint_set_ada_cmd (const char *args, int from_tty)
c6044dd1 354{
635c7e8a
TT
355 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
356 gdb_stdout);
c6044dd1
JB
357}
358
359/* Implement the "maintenance show ada" (prefix) command. */
360
361static void
981a3fb3 362maint_show_ada_cmd (const char *args, int from_tty)
c6044dd1
JB
363{
364 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
365}
366
367/* The "maintenance ada set/show ignore-descriptive-type" value. */
368
369static int ada_ignore_descriptive_types_p = 0;
370
e802dbe0
JB
371 /* Inferior-specific data. */
372
373/* Per-inferior data for this module. */
374
375struct ada_inferior_data
376{
377 /* The ada__tags__type_specific_data type, which is used when decoding
378 tagged types. With older versions of GNAT, this type was directly
379 accessible through a component ("tsd") in the object tag. But this
380 is no longer the case, so we cache it for each inferior. */
381 struct type *tsd_type;
3eecfa55
JB
382
383 /* The exception_support_info data. This data is used to determine
384 how to implement support for Ada exception catchpoints in a given
385 inferior. */
386 const struct exception_support_info *exception_info;
e802dbe0
JB
387};
388
389/* Our key to this module's inferior data. */
390static const struct inferior_data *ada_inferior_data;
391
392/* A cleanup routine for our inferior data. */
393static void
394ada_inferior_data_cleanup (struct inferior *inf, void *arg)
395{
396 struct ada_inferior_data *data;
397
9a3c8263 398 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
399 if (data != NULL)
400 xfree (data);
401}
402
403/* Return our inferior data for the given inferior (INF).
404
405 This function always returns a valid pointer to an allocated
406 ada_inferior_data structure. If INF's inferior data has not
407 been previously set, this functions creates a new one with all
408 fields set to zero, sets INF's inferior to it, and then returns
409 a pointer to that newly allocated ada_inferior_data. */
410
411static struct ada_inferior_data *
412get_ada_inferior_data (struct inferior *inf)
413{
414 struct ada_inferior_data *data;
415
9a3c8263 416 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
417 if (data == NULL)
418 {
41bf6aca 419 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
420 set_inferior_data (inf, ada_inferior_data, data);
421 }
422
423 return data;
424}
425
426/* Perform all necessary cleanups regarding our module's inferior data
427 that is required after the inferior INF just exited. */
428
429static void
430ada_inferior_exit (struct inferior *inf)
431{
432 ada_inferior_data_cleanup (inf, NULL);
433 set_inferior_data (inf, ada_inferior_data, NULL);
434}
435
ee01b665
JB
436
437 /* program-space-specific data. */
438
439/* This module's per-program-space data. */
440struct ada_pspace_data
441{
442 /* The Ada symbol cache. */
443 struct ada_symbol_cache *sym_cache;
444};
445
446/* Key to our per-program-space data. */
447static const struct program_space_data *ada_pspace_data_handle;
448
449/* Return this module's data for the given program space (PSPACE).
450 If not is found, add a zero'ed one now.
451
452 This function always returns a valid object. */
453
454static struct ada_pspace_data *
455get_ada_pspace_data (struct program_space *pspace)
456{
457 struct ada_pspace_data *data;
458
9a3c8263
SM
459 data = ((struct ada_pspace_data *)
460 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
461 if (data == NULL)
462 {
463 data = XCNEW (struct ada_pspace_data);
464 set_program_space_data (pspace, ada_pspace_data_handle, data);
465 }
466
467 return data;
468}
469
470/* The cleanup callback for this module's per-program-space data. */
471
472static void
473ada_pspace_data_cleanup (struct program_space *pspace, void *data)
474{
9a3c8263 475 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
476
477 if (pspace_data->sym_cache != NULL)
478 ada_free_symbol_cache (pspace_data->sym_cache);
479 xfree (pspace_data);
480}
481
4c4b4cd2
PH
482 /* Utilities */
483
720d1a40 484/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 485 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
486
487 Normally, we really expect a typedef type to only have 1 typedef layer.
488 In other words, we really expect the target type of a typedef type to be
489 a non-typedef type. This is particularly true for Ada units, because
490 the language does not have a typedef vs not-typedef distinction.
491 In that respect, the Ada compiler has been trying to eliminate as many
492 typedef definitions in the debugging information, since they generally
493 do not bring any extra information (we still use typedef under certain
494 circumstances related mostly to the GNAT encoding).
495
496 Unfortunately, we have seen situations where the debugging information
497 generated by the compiler leads to such multiple typedef layers. For
498 instance, consider the following example with stabs:
499
500 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
501 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
502
503 This is an error in the debugging information which causes type
504 pck__float_array___XUP to be defined twice, and the second time,
505 it is defined as a typedef of a typedef.
506
507 This is on the fringe of legality as far as debugging information is
508 concerned, and certainly unexpected. But it is easy to handle these
509 situations correctly, so we can afford to be lenient in this case. */
510
511static struct type *
512ada_typedef_target_type (struct type *type)
513{
514 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
515 type = TYPE_TARGET_TYPE (type);
516 return type;
517}
518
41d27058
JB
519/* Given DECODED_NAME a string holding a symbol name in its
520 decoded form (ie using the Ada dotted notation), returns
521 its unqualified name. */
522
523static const char *
524ada_unqualified_name (const char *decoded_name)
525{
2b0f535a
JB
526 const char *result;
527
528 /* If the decoded name starts with '<', it means that the encoded
529 name does not follow standard naming conventions, and thus that
530 it is not your typical Ada symbol name. Trying to unqualify it
531 is therefore pointless and possibly erroneous. */
532 if (decoded_name[0] == '<')
533 return decoded_name;
534
535 result = strrchr (decoded_name, '.');
41d27058
JB
536 if (result != NULL)
537 result++; /* Skip the dot... */
538 else
539 result = decoded_name;
540
541 return result;
542}
543
39e7af3e 544/* Return a string starting with '<', followed by STR, and '>'. */
41d27058 545
39e7af3e 546static std::string
41d27058
JB
547add_angle_brackets (const char *str)
548{
39e7af3e 549 return string_printf ("<%s>", str);
41d27058 550}
96d887e8 551
67cb5b2d 552static const char *
4c4b4cd2
PH
553ada_get_gdb_completer_word_break_characters (void)
554{
555 return ada_completer_word_break_characters;
556}
557
e79af960
JB
558/* Print an array element index using the Ada syntax. */
559
560static void
561ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 562 const struct value_print_options *options)
e79af960 563{
79a45b7d 564 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
565 fprintf_filtered (stream, " => ");
566}
567
f27cf670 568/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 569 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 570 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 571
f27cf670
AS
572void *
573grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 574{
d2e4a39e
AS
575 if (*size < min_size)
576 {
577 *size *= 2;
578 if (*size < min_size)
4c4b4cd2 579 *size = min_size;
f27cf670 580 vect = xrealloc (vect, *size * element_size);
d2e4a39e 581 }
f27cf670 582 return vect;
14f9c5c9
AS
583}
584
585/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 586 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
587
588static int
ebf56fd3 589field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
590{
591 int len = strlen (target);
5b4ee69b 592
d2e4a39e 593 return
4c4b4cd2
PH
594 (strncmp (field_name, target, len) == 0
595 && (field_name[len] == '\0'
61012eef 596 || (startswith (field_name + len, "___")
76a01679
JB
597 && strcmp (field_name + strlen (field_name) - 6,
598 "___XVN") != 0)));
14f9c5c9
AS
599}
600
601
872c8b51
JB
602/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
603 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
604 and return its index. This function also handles fields whose name
605 have ___ suffixes because the compiler sometimes alters their name
606 by adding such a suffix to represent fields with certain constraints.
607 If the field could not be found, return a negative number if
608 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
609
610int
611ada_get_field_index (const struct type *type, const char *field_name,
612 int maybe_missing)
613{
614 int fieldno;
872c8b51
JB
615 struct type *struct_type = check_typedef ((struct type *) type);
616
617 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
618 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
619 return fieldno;
620
621 if (!maybe_missing)
323e0a4a 622 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 623 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
624
625 return -1;
626}
627
628/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
629
630int
d2e4a39e 631ada_name_prefix_len (const char *name)
14f9c5c9
AS
632{
633 if (name == NULL)
634 return 0;
d2e4a39e 635 else
14f9c5c9 636 {
d2e4a39e 637 const char *p = strstr (name, "___");
5b4ee69b 638
14f9c5c9 639 if (p == NULL)
4c4b4cd2 640 return strlen (name);
14f9c5c9 641 else
4c4b4cd2 642 return p - name;
14f9c5c9
AS
643 }
644}
645
4c4b4cd2
PH
646/* Return non-zero if SUFFIX is a suffix of STR.
647 Return zero if STR is null. */
648
14f9c5c9 649static int
d2e4a39e 650is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
651{
652 int len1, len2;
5b4ee69b 653
14f9c5c9
AS
654 if (str == NULL)
655 return 0;
656 len1 = strlen (str);
657 len2 = strlen (suffix);
4c4b4cd2 658 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
659}
660
4c4b4cd2
PH
661/* The contents of value VAL, treated as a value of type TYPE. The
662 result is an lval in memory if VAL is. */
14f9c5c9 663
d2e4a39e 664static struct value *
4c4b4cd2 665coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 666{
61ee279c 667 type = ada_check_typedef (type);
df407dfe 668 if (value_type (val) == type)
4c4b4cd2 669 return val;
d2e4a39e 670 else
14f9c5c9 671 {
4c4b4cd2
PH
672 struct value *result;
673
674 /* Make sure that the object size is not unreasonable before
675 trying to allocate some memory for it. */
c1b5a1a6 676 ada_ensure_varsize_limit (type);
4c4b4cd2 677
41e8491f
JK
678 if (value_lazy (val)
679 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
680 result = allocate_value_lazy (type);
681 else
682 {
683 result = allocate_value (type);
9a0dc9e3 684 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 685 }
74bcbdf3 686 set_value_component_location (result, val);
9bbda503
AC
687 set_value_bitsize (result, value_bitsize (val));
688 set_value_bitpos (result, value_bitpos (val));
42ae5230 689 set_value_address (result, value_address (val));
14f9c5c9
AS
690 return result;
691 }
692}
693
fc1a4b47
AC
694static const gdb_byte *
695cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
696{
697 if (valaddr == NULL)
698 return NULL;
699 else
700 return valaddr + offset;
701}
702
703static CORE_ADDR
ebf56fd3 704cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
705{
706 if (address == 0)
707 return 0;
d2e4a39e 708 else
14f9c5c9
AS
709 return address + offset;
710}
711
4c4b4cd2
PH
712/* Issue a warning (as for the definition of warning in utils.c, but
713 with exactly one argument rather than ...), unless the limit on the
714 number of warnings has passed during the evaluation of the current
715 expression. */
a2249542 716
77109804
AC
717/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
718 provided by "complaint". */
a0b31db1 719static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 720
14f9c5c9 721static void
a2249542 722lim_warning (const char *format, ...)
14f9c5c9 723{
a2249542 724 va_list args;
a2249542 725
5b4ee69b 726 va_start (args, format);
4c4b4cd2
PH
727 warnings_issued += 1;
728 if (warnings_issued <= warning_limit)
a2249542
MK
729 vwarning (format, args);
730
731 va_end (args);
4c4b4cd2
PH
732}
733
714e53ab
PH
734/* Issue an error if the size of an object of type T is unreasonable,
735 i.e. if it would be a bad idea to allocate a value of this type in
736 GDB. */
737
c1b5a1a6
JB
738void
739ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
740{
741 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 742 error (_("object size is larger than varsize-limit"));
714e53ab
PH
743}
744
0963b4bd 745/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 746static LONGEST
c3e5cd34 747max_of_size (int size)
4c4b4cd2 748{
76a01679 749 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 750
76a01679 751 return top_bit | (top_bit - 1);
4c4b4cd2
PH
752}
753
0963b4bd 754/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 755static LONGEST
c3e5cd34 756min_of_size (int size)
4c4b4cd2 757{
c3e5cd34 758 return -max_of_size (size) - 1;
4c4b4cd2
PH
759}
760
0963b4bd 761/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 762static ULONGEST
c3e5cd34 763umax_of_size (int size)
4c4b4cd2 764{
76a01679 765 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 766
76a01679 767 return top_bit | (top_bit - 1);
4c4b4cd2
PH
768}
769
0963b4bd 770/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
771static LONGEST
772max_of_type (struct type *t)
4c4b4cd2 773{
c3e5cd34
PH
774 if (TYPE_UNSIGNED (t))
775 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
776 else
777 return max_of_size (TYPE_LENGTH (t));
778}
779
0963b4bd 780/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
781static LONGEST
782min_of_type (struct type *t)
783{
784 if (TYPE_UNSIGNED (t))
785 return 0;
786 else
787 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
788}
789
790/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
791LONGEST
792ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 793{
c3345124 794 type = resolve_dynamic_type (type, NULL, 0);
76a01679 795 switch (TYPE_CODE (type))
4c4b4cd2
PH
796 {
797 case TYPE_CODE_RANGE:
690cc4eb 798 return TYPE_HIGH_BOUND (type);
4c4b4cd2 799 case TYPE_CODE_ENUM:
14e75d8e 800 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
801 case TYPE_CODE_BOOL:
802 return 1;
803 case TYPE_CODE_CHAR:
76a01679 804 case TYPE_CODE_INT:
690cc4eb 805 return max_of_type (type);
4c4b4cd2 806 default:
43bbcdc2 807 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
808 }
809}
810
14e75d8e 811/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
812LONGEST
813ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 814{
c3345124 815 type = resolve_dynamic_type (type, NULL, 0);
76a01679 816 switch (TYPE_CODE (type))
4c4b4cd2
PH
817 {
818 case TYPE_CODE_RANGE:
690cc4eb 819 return TYPE_LOW_BOUND (type);
4c4b4cd2 820 case TYPE_CODE_ENUM:
14e75d8e 821 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
822 case TYPE_CODE_BOOL:
823 return 0;
824 case TYPE_CODE_CHAR:
76a01679 825 case TYPE_CODE_INT:
690cc4eb 826 return min_of_type (type);
4c4b4cd2 827 default:
43bbcdc2 828 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
829 }
830}
831
832/* The identity on non-range types. For range types, the underlying
76a01679 833 non-range scalar type. */
4c4b4cd2
PH
834
835static struct type *
18af8284 836get_base_type (struct type *type)
4c4b4cd2
PH
837{
838 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
839 {
76a01679
JB
840 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
841 return type;
4c4b4cd2
PH
842 type = TYPE_TARGET_TYPE (type);
843 }
844 return type;
14f9c5c9 845}
41246937
JB
846
847/* Return a decoded version of the given VALUE. This means returning
848 a value whose type is obtained by applying all the GNAT-specific
849 encondings, making the resulting type a static but standard description
850 of the initial type. */
851
852struct value *
853ada_get_decoded_value (struct value *value)
854{
855 struct type *type = ada_check_typedef (value_type (value));
856
857 if (ada_is_array_descriptor_type (type)
858 || (ada_is_constrained_packed_array_type (type)
859 && TYPE_CODE (type) != TYPE_CODE_PTR))
860 {
861 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
862 value = ada_coerce_to_simple_array_ptr (value);
863 else
864 value = ada_coerce_to_simple_array (value);
865 }
866 else
867 value = ada_to_fixed_value (value);
868
869 return value;
870}
871
872/* Same as ada_get_decoded_value, but with the given TYPE.
873 Because there is no associated actual value for this type,
874 the resulting type might be a best-effort approximation in
875 the case of dynamic types. */
876
877struct type *
878ada_get_decoded_type (struct type *type)
879{
880 type = to_static_fixed_type (type);
881 if (ada_is_constrained_packed_array_type (type))
882 type = ada_coerce_to_simple_array_type (type);
883 return type;
884}
885
4c4b4cd2 886\f
76a01679 887
4c4b4cd2 888 /* Language Selection */
14f9c5c9
AS
889
890/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 891 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 892
14f9c5c9 893enum language
ccefe4c4 894ada_update_initial_language (enum language lang)
14f9c5c9 895{
d2e4a39e 896 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 897 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 898 return language_ada;
14f9c5c9
AS
899
900 return lang;
901}
96d887e8
PH
902
903/* If the main procedure is written in Ada, then return its name.
904 The result is good until the next call. Return NULL if the main
905 procedure doesn't appear to be in Ada. */
906
907char *
908ada_main_name (void)
909{
3b7344d5 910 struct bound_minimal_symbol msym;
e83e4e24 911 static gdb::unique_xmalloc_ptr<char> main_program_name;
6c038f32 912
96d887e8
PH
913 /* For Ada, the name of the main procedure is stored in a specific
914 string constant, generated by the binder. Look for that symbol,
915 extract its address, and then read that string. If we didn't find
916 that string, then most probably the main procedure is not written
917 in Ada. */
918 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
919
3b7344d5 920 if (msym.minsym != NULL)
96d887e8 921 {
f9bc20b9
JB
922 CORE_ADDR main_program_name_addr;
923 int err_code;
924
77e371c0 925 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 926 if (main_program_name_addr == 0)
323e0a4a 927 error (_("Invalid address for Ada main program name."));
96d887e8 928
f9bc20b9
JB
929 target_read_string (main_program_name_addr, &main_program_name,
930 1024, &err_code);
931
932 if (err_code != 0)
933 return NULL;
e83e4e24 934 return main_program_name.get ();
96d887e8
PH
935 }
936
937 /* The main procedure doesn't seem to be in Ada. */
938 return NULL;
939}
14f9c5c9 940\f
4c4b4cd2 941 /* Symbols */
d2e4a39e 942
4c4b4cd2
PH
943/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
944 of NULLs. */
14f9c5c9 945
d2e4a39e
AS
946const struct ada_opname_map ada_opname_table[] = {
947 {"Oadd", "\"+\"", BINOP_ADD},
948 {"Osubtract", "\"-\"", BINOP_SUB},
949 {"Omultiply", "\"*\"", BINOP_MUL},
950 {"Odivide", "\"/\"", BINOP_DIV},
951 {"Omod", "\"mod\"", BINOP_MOD},
952 {"Orem", "\"rem\"", BINOP_REM},
953 {"Oexpon", "\"**\"", BINOP_EXP},
954 {"Olt", "\"<\"", BINOP_LESS},
955 {"Ole", "\"<=\"", BINOP_LEQ},
956 {"Ogt", "\">\"", BINOP_GTR},
957 {"Oge", "\">=\"", BINOP_GEQ},
958 {"Oeq", "\"=\"", BINOP_EQUAL},
959 {"One", "\"/=\"", BINOP_NOTEQUAL},
960 {"Oand", "\"and\"", BINOP_BITWISE_AND},
961 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
962 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
963 {"Oconcat", "\"&\"", BINOP_CONCAT},
964 {"Oabs", "\"abs\"", UNOP_ABS},
965 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
966 {"Oadd", "\"+\"", UNOP_PLUS},
967 {"Osubtract", "\"-\"", UNOP_NEG},
968 {NULL, NULL}
14f9c5c9
AS
969};
970
b5ec771e
PA
971/* The "encoded" form of DECODED, according to GNAT conventions. The
972 result is valid until the next call to ada_encode. If
973 THROW_ERRORS, throw an error if invalid operator name is found.
974 Otherwise, return NULL in that case. */
4c4b4cd2 975
b5ec771e
PA
976static char *
977ada_encode_1 (const char *decoded, bool throw_errors)
14f9c5c9 978{
4c4b4cd2
PH
979 static char *encoding_buffer = NULL;
980 static size_t encoding_buffer_size = 0;
d2e4a39e 981 const char *p;
14f9c5c9 982 int k;
d2e4a39e 983
4c4b4cd2 984 if (decoded == NULL)
14f9c5c9
AS
985 return NULL;
986
4c4b4cd2
PH
987 GROW_VECT (encoding_buffer, encoding_buffer_size,
988 2 * strlen (decoded) + 10);
14f9c5c9
AS
989
990 k = 0;
4c4b4cd2 991 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 992 {
cdc7bb92 993 if (*p == '.')
4c4b4cd2
PH
994 {
995 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
996 k += 2;
997 }
14f9c5c9 998 else if (*p == '"')
4c4b4cd2
PH
999 {
1000 const struct ada_opname_map *mapping;
1001
1002 for (mapping = ada_opname_table;
1265e4aa 1003 mapping->encoded != NULL
61012eef 1004 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1005 ;
1006 if (mapping->encoded == NULL)
b5ec771e
PA
1007 {
1008 if (throw_errors)
1009 error (_("invalid Ada operator name: %s"), p);
1010 else
1011 return NULL;
1012 }
4c4b4cd2
PH
1013 strcpy (encoding_buffer + k, mapping->encoded);
1014 k += strlen (mapping->encoded);
1015 break;
1016 }
d2e4a39e 1017 else
4c4b4cd2
PH
1018 {
1019 encoding_buffer[k] = *p;
1020 k += 1;
1021 }
14f9c5c9
AS
1022 }
1023
4c4b4cd2
PH
1024 encoding_buffer[k] = '\0';
1025 return encoding_buffer;
14f9c5c9
AS
1026}
1027
b5ec771e
PA
1028/* The "encoded" form of DECODED, according to GNAT conventions.
1029 The result is valid until the next call to ada_encode. */
1030
1031char *
1032ada_encode (const char *decoded)
1033{
1034 return ada_encode_1 (decoded, true);
1035}
1036
14f9c5c9 1037/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1038 quotes, unfolded, but with the quotes stripped away. Result good
1039 to next call. */
1040
d2e4a39e
AS
1041char *
1042ada_fold_name (const char *name)
14f9c5c9 1043{
d2e4a39e 1044 static char *fold_buffer = NULL;
14f9c5c9
AS
1045 static size_t fold_buffer_size = 0;
1046
1047 int len = strlen (name);
d2e4a39e 1048 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1049
1050 if (name[0] == '\'')
1051 {
d2e4a39e
AS
1052 strncpy (fold_buffer, name + 1, len - 2);
1053 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1054 }
1055 else
1056 {
1057 int i;
5b4ee69b 1058
14f9c5c9 1059 for (i = 0; i <= len; i += 1)
4c4b4cd2 1060 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1061 }
1062
1063 return fold_buffer;
1064}
1065
529cad9c
PH
1066/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1067
1068static int
1069is_lower_alphanum (const char c)
1070{
1071 return (isdigit (c) || (isalpha (c) && islower (c)));
1072}
1073
c90092fe
JB
1074/* ENCODED is the linkage name of a symbol and LEN contains its length.
1075 This function saves in LEN the length of that same symbol name but
1076 without either of these suffixes:
29480c32
JB
1077 . .{DIGIT}+
1078 . ${DIGIT}+
1079 . ___{DIGIT}+
1080 . __{DIGIT}+.
c90092fe 1081
29480c32
JB
1082 These are suffixes introduced by the compiler for entities such as
1083 nested subprogram for instance, in order to avoid name clashes.
1084 They do not serve any purpose for the debugger. */
1085
1086static void
1087ada_remove_trailing_digits (const char *encoded, int *len)
1088{
1089 if (*len > 1 && isdigit (encoded[*len - 1]))
1090 {
1091 int i = *len - 2;
5b4ee69b 1092
29480c32
JB
1093 while (i > 0 && isdigit (encoded[i]))
1094 i--;
1095 if (i >= 0 && encoded[i] == '.')
1096 *len = i;
1097 else if (i >= 0 && encoded[i] == '$')
1098 *len = i;
61012eef 1099 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1100 *len = i - 2;
61012eef 1101 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1102 *len = i - 1;
1103 }
1104}
1105
1106/* Remove the suffix introduced by the compiler for protected object
1107 subprograms. */
1108
1109static void
1110ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1111{
1112 /* Remove trailing N. */
1113
1114 /* Protected entry subprograms are broken into two
1115 separate subprograms: The first one is unprotected, and has
1116 a 'N' suffix; the second is the protected version, and has
0963b4bd 1117 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1118 the protection. Since the P subprograms are internally generated,
1119 we leave these names undecoded, giving the user a clue that this
1120 entity is internal. */
1121
1122 if (*len > 1
1123 && encoded[*len - 1] == 'N'
1124 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1125 *len = *len - 1;
1126}
1127
69fadcdf
JB
1128/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1129
1130static void
1131ada_remove_Xbn_suffix (const char *encoded, int *len)
1132{
1133 int i = *len - 1;
1134
1135 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1136 i--;
1137
1138 if (encoded[i] != 'X')
1139 return;
1140
1141 if (i == 0)
1142 return;
1143
1144 if (isalnum (encoded[i-1]))
1145 *len = i;
1146}
1147
29480c32
JB
1148/* If ENCODED follows the GNAT entity encoding conventions, then return
1149 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1150 replaced by ENCODED.
14f9c5c9 1151
4c4b4cd2 1152 The resulting string is valid until the next call of ada_decode.
29480c32 1153 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1154 is returned. */
1155
1156const char *
1157ada_decode (const char *encoded)
14f9c5c9
AS
1158{
1159 int i, j;
1160 int len0;
d2e4a39e 1161 const char *p;
4c4b4cd2 1162 char *decoded;
14f9c5c9 1163 int at_start_name;
4c4b4cd2
PH
1164 static char *decoding_buffer = NULL;
1165 static size_t decoding_buffer_size = 0;
d2e4a39e 1166
0d81f350
JG
1167 /* With function descriptors on PPC64, the value of a symbol named
1168 ".FN", if it exists, is the entry point of the function "FN". */
1169 if (encoded[0] == '.')
1170 encoded += 1;
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))))
2a62dfa9
JB
2817 {
2818 int src_offset;
2819
2820 if (is_scalar_type (check_typedef (value_type (component))))
2821 src_offset
2822 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits;
2823 else
2824 src_offset = 0;
2825 move_bits (value_contents_writeable (container) + offset_in_container,
2826 value_bitpos (container) + bit_offset_in_container,
2827 value_contents (val), src_offset, bits, 1);
2828 }
52ce6436 2829 else
7c512744 2830 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2831 value_bitpos (container) + bit_offset_in_container,
50810684 2832 value_contents (val), 0, bits, 0);
7c512744
JB
2833}
2834
4c4b4cd2
PH
2835/* The value of the element of array ARR at the ARITY indices given in IND.
2836 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2837 thereto. */
2838
d2e4a39e
AS
2839struct value *
2840ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2841{
2842 int k;
d2e4a39e
AS
2843 struct value *elt;
2844 struct type *elt_type;
14f9c5c9
AS
2845
2846 elt = ada_coerce_to_simple_array (arr);
2847
df407dfe 2848 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2849 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2850 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2851 return value_subscript_packed (elt, arity, ind);
2852
2853 for (k = 0; k < arity; k += 1)
2854 {
2855 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2856 error (_("too many subscripts (%d expected)"), k);
2497b498 2857 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2858 }
2859 return elt;
2860}
2861
deede10c
JB
2862/* Assuming ARR is a pointer to a GDB array, the value of the element
2863 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2864 Does not read the entire array into memory.
2865
2866 Note: Unlike what one would expect, this function is used instead of
2867 ada_value_subscript for basically all non-packed array types. The reason
2868 for this is that a side effect of doing our own pointer arithmetics instead
2869 of relying on value_subscript is that there is no implicit typedef peeling.
2870 This is important for arrays of array accesses, where it allows us to
2871 preserve the fact that the array's element is an array access, where the
2872 access part os encoded in a typedef layer. */
14f9c5c9 2873
2c0b251b 2874static struct value *
deede10c 2875ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2876{
2877 int k;
919e6dbe 2878 struct value *array_ind = ada_value_ind (arr);
deede10c 2879 struct type *type
919e6dbe
PMR
2880 = check_typedef (value_enclosing_type (array_ind));
2881
2882 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2883 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2884 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2885
2886 for (k = 0; k < arity; k += 1)
2887 {
2888 LONGEST lwb, upb;
aa715135 2889 struct value *lwb_value;
14f9c5c9
AS
2890
2891 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2892 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2893 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2894 value_copy (arr));
14f9c5c9 2895 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2896 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2897 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2898 type = TYPE_TARGET_TYPE (type);
2899 }
2900
2901 return value_ind (arr);
2902}
2903
0b5d8877 2904/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2905 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2906 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2907 this array is LOW, as per Ada rules. */
0b5d8877 2908static struct value *
f5938064
JG
2909ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2910 int low, int high)
0b5d8877 2911{
b0dd7688 2912 struct type *type0 = ada_check_typedef (type);
aa715135 2913 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2914 struct type *index_type
aa715135 2915 = create_static_range_type (NULL, base_index_type, low, high);
9fe561ab
JB
2916 struct type *slice_type = create_array_type_with_stride
2917 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2918 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2919 TYPE_FIELD_BITSIZE (type0, 0));
aa715135
JG
2920 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2921 LONGEST base_low_pos, low_pos;
2922 CORE_ADDR base;
2923
2924 if (!discrete_position (base_index_type, low, &low_pos)
2925 || !discrete_position (base_index_type, base_low, &base_low_pos))
2926 {
2927 warning (_("unable to get positions in slice, use bounds instead"));
2928 low_pos = low;
2929 base_low_pos = base_low;
2930 }
5b4ee69b 2931
aa715135
JG
2932 base = value_as_address (array_ptr)
2933 + ((low_pos - base_low_pos)
2934 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2935 return value_at_lazy (slice_type, base);
0b5d8877
PH
2936}
2937
2938
2939static struct value *
2940ada_value_slice (struct value *array, int low, int high)
2941{
b0dd7688 2942 struct type *type = ada_check_typedef (value_type (array));
aa715135 2943 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2944 struct type *index_type
2945 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
9fe561ab
JB
2946 struct type *slice_type = create_array_type_with_stride
2947 (NULL, TYPE_TARGET_TYPE (type), index_type,
2948 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2949 TYPE_FIELD_BITSIZE (type, 0));
aa715135 2950 LONGEST low_pos, high_pos;
5b4ee69b 2951
aa715135
JG
2952 if (!discrete_position (base_index_type, low, &low_pos)
2953 || !discrete_position (base_index_type, high, &high_pos))
2954 {
2955 warning (_("unable to get positions in slice, use bounds instead"));
2956 low_pos = low;
2957 high_pos = high;
2958 }
2959
2960 return value_cast (slice_type,
2961 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2962}
2963
14f9c5c9
AS
2964/* If type is a record type in the form of a standard GNAT array
2965 descriptor, returns the number of dimensions for type. If arr is a
2966 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2967 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2968
2969int
d2e4a39e 2970ada_array_arity (struct type *type)
14f9c5c9
AS
2971{
2972 int arity;
2973
2974 if (type == NULL)
2975 return 0;
2976
2977 type = desc_base_type (type);
2978
2979 arity = 0;
d2e4a39e 2980 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2981 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2982 else
2983 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2984 {
4c4b4cd2 2985 arity += 1;
61ee279c 2986 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2987 }
d2e4a39e 2988
14f9c5c9
AS
2989 return arity;
2990}
2991
2992/* If TYPE is a record type in the form of a standard GNAT array
2993 descriptor or a simple array type, returns the element type for
2994 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2995 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2996
d2e4a39e
AS
2997struct type *
2998ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2999{
3000 type = desc_base_type (type);
3001
d2e4a39e 3002 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
3003 {
3004 int k;
d2e4a39e 3005 struct type *p_array_type;
14f9c5c9 3006
556bdfd4 3007 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
3008
3009 k = ada_array_arity (type);
3010 if (k == 0)
4c4b4cd2 3011 return NULL;
d2e4a39e 3012
4c4b4cd2 3013 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 3014 if (nindices >= 0 && k > nindices)
4c4b4cd2 3015 k = nindices;
d2e4a39e 3016 while (k > 0 && p_array_type != NULL)
4c4b4cd2 3017 {
61ee279c 3018 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
3019 k -= 1;
3020 }
14f9c5c9
AS
3021 return p_array_type;
3022 }
3023 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3024 {
3025 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3026 {
3027 type = TYPE_TARGET_TYPE (type);
3028 nindices -= 1;
3029 }
14f9c5c9
AS
3030 return type;
3031 }
3032
3033 return NULL;
3034}
3035
4c4b4cd2 3036/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3037 Does not examine memory. Throws an error if N is invalid or TYPE
3038 is not an array type. NAME is the name of the Ada attribute being
3039 evaluated ('range, 'first, 'last, or 'length); it is used in building
3040 the error message. */
14f9c5c9 3041
1eea4ebd
UW
3042static struct type *
3043ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3044{
4c4b4cd2
PH
3045 struct type *result_type;
3046
14f9c5c9
AS
3047 type = desc_base_type (type);
3048
1eea4ebd
UW
3049 if (n < 0 || n > ada_array_arity (type))
3050 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3051
4c4b4cd2 3052 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3053 {
3054 int i;
3055
3056 for (i = 1; i < n; i += 1)
4c4b4cd2 3057 type = TYPE_TARGET_TYPE (type);
262452ec 3058 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3059 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3060 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3061 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3062 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3063 result_type = NULL;
14f9c5c9 3064 }
d2e4a39e 3065 else
1eea4ebd
UW
3066 {
3067 result_type = desc_index_type (desc_bounds_type (type), n);
3068 if (result_type == NULL)
3069 error (_("attempt to take bound of something that is not an array"));
3070 }
3071
3072 return result_type;
14f9c5c9
AS
3073}
3074
3075/* Given that arr is an array type, returns the lower bound of the
3076 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3077 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3078 array-descriptor type. It works for other arrays with bounds supplied
3079 by run-time quantities other than discriminants. */
14f9c5c9 3080
abb68b3e 3081static LONGEST
fb5e3d5c 3082ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3083{
8a48ac95 3084 struct type *type, *index_type_desc, *index_type;
1ce677a4 3085 int i;
262452ec
JK
3086
3087 gdb_assert (which == 0 || which == 1);
14f9c5c9 3088
ad82864c
JB
3089 if (ada_is_constrained_packed_array_type (arr_type))
3090 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3091
4c4b4cd2 3092 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3093 return (LONGEST) - which;
14f9c5c9
AS
3094
3095 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3096 type = TYPE_TARGET_TYPE (arr_type);
3097 else
3098 type = arr_type;
3099
bafffb51
JB
3100 if (TYPE_FIXED_INSTANCE (type))
3101 {
3102 /* The array has already been fixed, so we do not need to
3103 check the parallel ___XA type again. That encoding has
3104 already been applied, so ignore it now. */
3105 index_type_desc = NULL;
3106 }
3107 else
3108 {
3109 index_type_desc = ada_find_parallel_type (type, "___XA");
3110 ada_fixup_array_indexes_type (index_type_desc);
3111 }
3112
262452ec 3113 if (index_type_desc != NULL)
28c85d6c
JB
3114 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3115 NULL);
262452ec 3116 else
8a48ac95
JB
3117 {
3118 struct type *elt_type = check_typedef (type);
3119
3120 for (i = 1; i < n; i++)
3121 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3122
3123 index_type = TYPE_INDEX_TYPE (elt_type);
3124 }
262452ec 3125
43bbcdc2
PH
3126 return
3127 (LONGEST) (which == 0
3128 ? ada_discrete_type_low_bound (index_type)
3129 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3130}
3131
3132/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3133 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3134 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3135 supplied by run-time quantities other than discriminants. */
14f9c5c9 3136
1eea4ebd 3137static LONGEST
4dc81987 3138ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3139{
eb479039
JB
3140 struct type *arr_type;
3141
3142 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3143 arr = value_ind (arr);
3144 arr_type = value_enclosing_type (arr);
14f9c5c9 3145
ad82864c
JB
3146 if (ada_is_constrained_packed_array_type (arr_type))
3147 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3148 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3149 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3150 else
1eea4ebd 3151 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3152}
3153
3154/* Given that arr is an array value, returns the length of the
3155 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3156 supplied by run-time quantities other than discriminants.
3157 Does not work for arrays indexed by enumeration types with representation
3158 clauses at the moment. */
14f9c5c9 3159
1eea4ebd 3160static LONGEST
d2e4a39e 3161ada_array_length (struct value *arr, int n)
14f9c5c9 3162{
aa715135
JG
3163 struct type *arr_type, *index_type;
3164 int low, high;
eb479039
JB
3165
3166 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3167 arr = value_ind (arr);
3168 arr_type = value_enclosing_type (arr);
14f9c5c9 3169
ad82864c
JB
3170 if (ada_is_constrained_packed_array_type (arr_type))
3171 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3172
4c4b4cd2 3173 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3174 {
3175 low = ada_array_bound_from_type (arr_type, n, 0);
3176 high = ada_array_bound_from_type (arr_type, n, 1);
3177 }
14f9c5c9 3178 else
aa715135
JG
3179 {
3180 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3181 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3182 }
3183
f168693b 3184 arr_type = check_typedef (arr_type);
7150d33c 3185 index_type = ada_index_type (arr_type, n, "length");
aa715135
JG
3186 if (index_type != NULL)
3187 {
3188 struct type *base_type;
3189 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3190 base_type = TYPE_TARGET_TYPE (index_type);
3191 else
3192 base_type = index_type;
3193
3194 low = pos_atr (value_from_longest (base_type, low));
3195 high = pos_atr (value_from_longest (base_type, high));
3196 }
3197 return high - low + 1;
4c4b4cd2
PH
3198}
3199
3200/* An empty array whose type is that of ARR_TYPE (an array type),
3201 with bounds LOW to LOW-1. */
3202
3203static struct value *
3204empty_array (struct type *arr_type, int low)
3205{
b0dd7688 3206 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3207 struct type *index_type
3208 = create_static_range_type
3209 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3210 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3211
0b5d8877 3212 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3213}
14f9c5c9 3214\f
d2e4a39e 3215
4c4b4cd2 3216 /* Name resolution */
14f9c5c9 3217
4c4b4cd2
PH
3218/* The "decoded" name for the user-definable Ada operator corresponding
3219 to OP. */
14f9c5c9 3220
d2e4a39e 3221static const char *
4c4b4cd2 3222ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3223{
3224 int i;
3225
4c4b4cd2 3226 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3227 {
3228 if (ada_opname_table[i].op == op)
4c4b4cd2 3229 return ada_opname_table[i].decoded;
14f9c5c9 3230 }
323e0a4a 3231 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3232}
3233
3234
4c4b4cd2
PH
3235/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3236 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3237 undefined namespace) and converts operators that are
3238 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3239 non-null, it provides a preferred result type [at the moment, only
3240 type void has any effect---causing procedures to be preferred over
3241 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3242 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3243
4c4b4cd2 3244static void
e9d9f57e 3245resolve (expression_up *expp, int void_context_p)
14f9c5c9 3246{
30b15541
UW
3247 struct type *context_type = NULL;
3248 int pc = 0;
3249
3250 if (void_context_p)
3251 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3252
3253 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3254}
3255
4c4b4cd2
PH
3256/* Resolve the operator of the subexpression beginning at
3257 position *POS of *EXPP. "Resolving" consists of replacing
3258 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3259 with their resolutions, replacing built-in operators with
3260 function calls to user-defined operators, where appropriate, and,
3261 when DEPROCEDURE_P is non-zero, converting function-valued variables
3262 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3263 are as in ada_resolve, above. */
14f9c5c9 3264
d2e4a39e 3265static struct value *
e9d9f57e 3266resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
76a01679 3267 struct type *context_type)
14f9c5c9
AS
3268{
3269 int pc = *pos;
3270 int i;
4c4b4cd2 3271 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3272 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3273 struct value **argvec; /* Vector of operand types (alloca'ed). */
3274 int nargs; /* Number of operands. */
52ce6436 3275 int oplen;
14f9c5c9
AS
3276
3277 argvec = NULL;
3278 nargs = 0;
e9d9f57e 3279 exp = expp->get ();
14f9c5c9 3280
52ce6436
PH
3281 /* Pass one: resolve operands, saving their types and updating *pos,
3282 if needed. */
14f9c5c9
AS
3283 switch (op)
3284 {
4c4b4cd2
PH
3285 case OP_FUNCALL:
3286 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3287 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3288 *pos += 7;
4c4b4cd2
PH
3289 else
3290 {
3291 *pos += 3;
3292 resolve_subexp (expp, pos, 0, NULL);
3293 }
3294 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3295 break;
3296
14f9c5c9 3297 case UNOP_ADDR:
4c4b4cd2
PH
3298 *pos += 1;
3299 resolve_subexp (expp, pos, 0, NULL);
3300 break;
3301
52ce6436
PH
3302 case UNOP_QUAL:
3303 *pos += 3;
17466c1a 3304 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3305 break;
3306
52ce6436 3307 case OP_ATR_MODULUS:
4c4b4cd2
PH
3308 case OP_ATR_SIZE:
3309 case OP_ATR_TAG:
4c4b4cd2
PH
3310 case OP_ATR_FIRST:
3311 case OP_ATR_LAST:
3312 case OP_ATR_LENGTH:
3313 case OP_ATR_POS:
3314 case OP_ATR_VAL:
4c4b4cd2
PH
3315 case OP_ATR_MIN:
3316 case OP_ATR_MAX:
52ce6436
PH
3317 case TERNOP_IN_RANGE:
3318 case BINOP_IN_BOUNDS:
3319 case UNOP_IN_RANGE:
3320 case OP_AGGREGATE:
3321 case OP_OTHERS:
3322 case OP_CHOICES:
3323 case OP_POSITIONAL:
3324 case OP_DISCRETE_RANGE:
3325 case OP_NAME:
3326 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3327 *pos += oplen;
14f9c5c9
AS
3328 break;
3329
3330 case BINOP_ASSIGN:
3331 {
4c4b4cd2
PH
3332 struct value *arg1;
3333
3334 *pos += 1;
3335 arg1 = resolve_subexp (expp, pos, 0, NULL);
3336 if (arg1 == NULL)
3337 resolve_subexp (expp, pos, 1, NULL);
3338 else
df407dfe 3339 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3340 break;
14f9c5c9
AS
3341 }
3342
4c4b4cd2 3343 case UNOP_CAST:
4c4b4cd2
PH
3344 *pos += 3;
3345 nargs = 1;
3346 break;
14f9c5c9 3347
4c4b4cd2
PH
3348 case BINOP_ADD:
3349 case BINOP_SUB:
3350 case BINOP_MUL:
3351 case BINOP_DIV:
3352 case BINOP_REM:
3353 case BINOP_MOD:
3354 case BINOP_EXP:
3355 case BINOP_CONCAT:
3356 case BINOP_LOGICAL_AND:
3357 case BINOP_LOGICAL_OR:
3358 case BINOP_BITWISE_AND:
3359 case BINOP_BITWISE_IOR:
3360 case BINOP_BITWISE_XOR:
14f9c5c9 3361
4c4b4cd2
PH
3362 case BINOP_EQUAL:
3363 case BINOP_NOTEQUAL:
3364 case BINOP_LESS:
3365 case BINOP_GTR:
3366 case BINOP_LEQ:
3367 case BINOP_GEQ:
14f9c5c9 3368
4c4b4cd2
PH
3369 case BINOP_REPEAT:
3370 case BINOP_SUBSCRIPT:
3371 case BINOP_COMMA:
40c8aaa9
JB
3372 *pos += 1;
3373 nargs = 2;
3374 break;
14f9c5c9 3375
4c4b4cd2
PH
3376 case UNOP_NEG:
3377 case UNOP_PLUS:
3378 case UNOP_LOGICAL_NOT:
3379 case UNOP_ABS:
3380 case UNOP_IND:
3381 *pos += 1;
3382 nargs = 1;
3383 break;
14f9c5c9 3384
4c4b4cd2 3385 case OP_LONG:
edd079d9 3386 case OP_FLOAT:
4c4b4cd2 3387 case OP_VAR_VALUE:
74ea4be4 3388 case OP_VAR_MSYM_VALUE:
4c4b4cd2
PH
3389 *pos += 4;
3390 break;
14f9c5c9 3391
4c4b4cd2
PH
3392 case OP_TYPE:
3393 case OP_BOOL:
3394 case OP_LAST:
4c4b4cd2
PH
3395 case OP_INTERNALVAR:
3396 *pos += 3;
3397 break;
14f9c5c9 3398
4c4b4cd2
PH
3399 case UNOP_MEMVAL:
3400 *pos += 3;
3401 nargs = 1;
3402 break;
3403
67f3407f
DJ
3404 case OP_REGISTER:
3405 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3406 break;
3407
4c4b4cd2
PH
3408 case STRUCTOP_STRUCT:
3409 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3410 nargs = 1;
3411 break;
3412
4c4b4cd2 3413 case TERNOP_SLICE:
4c4b4cd2
PH
3414 *pos += 1;
3415 nargs = 3;
3416 break;
3417
52ce6436 3418 case OP_STRING:
14f9c5c9 3419 break;
4c4b4cd2
PH
3420
3421 default:
323e0a4a 3422 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3423 }
3424
8d749320 3425 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2
PH
3426 for (i = 0; i < nargs; i += 1)
3427 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3428 argvec[i] = NULL;
e9d9f57e 3429 exp = expp->get ();
4c4b4cd2
PH
3430
3431 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3432 switch (op)
3433 {
3434 default:
3435 break;
3436
14f9c5c9 3437 case OP_VAR_VALUE:
4c4b4cd2 3438 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3439 {
54d343a2 3440 std::vector<struct block_symbol> candidates;
76a01679
JB
3441 int n_candidates;
3442
3443 n_candidates =
3444 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3445 (exp->elts[pc + 2].symbol),
3446 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3447 &candidates);
76a01679
JB
3448
3449 if (n_candidates > 1)
3450 {
3451 /* Types tend to get re-introduced locally, so if there
3452 are any local symbols that are not types, first filter
3453 out all types. */
3454 int j;
3455 for (j = 0; j < n_candidates; j += 1)
d12307c1 3456 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3457 {
3458 case LOC_REGISTER:
3459 case LOC_ARG:
3460 case LOC_REF_ARG:
76a01679
JB
3461 case LOC_REGPARM_ADDR:
3462 case LOC_LOCAL:
76a01679 3463 case LOC_COMPUTED:
76a01679
JB
3464 goto FoundNonType;
3465 default:
3466 break;
3467 }
3468 FoundNonType:
3469 if (j < n_candidates)
3470 {
3471 j = 0;
3472 while (j < n_candidates)
3473 {
d12307c1 3474 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3475 {
3476 candidates[j] = candidates[n_candidates - 1];
3477 n_candidates -= 1;
3478 }
3479 else
3480 j += 1;
3481 }
3482 }
3483 }
3484
3485 if (n_candidates == 0)
323e0a4a 3486 error (_("No definition found for %s"),
76a01679
JB
3487 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3488 else if (n_candidates == 1)
3489 i = 0;
3490 else if (deprocedure_p
54d343a2 3491 && !is_nonfunction (candidates.data (), n_candidates))
76a01679 3492 {
06d5cf63 3493 i = ada_resolve_function
54d343a2 3494 (candidates.data (), n_candidates, NULL, 0,
06d5cf63
JB
3495 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3496 context_type);
76a01679 3497 if (i < 0)
323e0a4a 3498 error (_("Could not find a match for %s"),
76a01679
JB
3499 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3500 }
3501 else
3502 {
323e0a4a 3503 printf_filtered (_("Multiple matches for %s\n"),
76a01679 3504 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
54d343a2 3505 user_select_syms (candidates.data (), n_candidates, 1);
76a01679
JB
3506 i = 0;
3507 }
3508
3509 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3510 exp->elts[pc + 2].symbol = candidates[i].symbol;
aee1fcdf 3511 innermost_block.update (candidates[i]);
76a01679
JB
3512 }
3513
3514 if (deprocedure_p
3515 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3516 == TYPE_CODE_FUNC))
3517 {
424da6cf 3518 replace_operator_with_call (expp, pc, 0, 4,
76a01679
JB
3519 exp->elts[pc + 2].symbol,
3520 exp->elts[pc + 1].block);
e9d9f57e 3521 exp = expp->get ();
76a01679 3522 }
14f9c5c9
AS
3523 break;
3524
3525 case OP_FUNCALL:
3526 {
4c4b4cd2 3527 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3528 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3529 {
54d343a2 3530 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3531 int n_candidates;
3532
3533 n_candidates =
76a01679
JB
3534 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3535 (exp->elts[pc + 5].symbol),
3536 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3537 &candidates);
ec6a20c2 3538
4c4b4cd2
PH
3539 if (n_candidates == 1)
3540 i = 0;
3541 else
3542 {
06d5cf63 3543 i = ada_resolve_function
54d343a2 3544 (candidates.data (), n_candidates,
06d5cf63
JB
3545 argvec, nargs,
3546 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3547 context_type);
4c4b4cd2 3548 if (i < 0)
323e0a4a 3549 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3550 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3551 }
3552
3553 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3554 exp->elts[pc + 5].symbol = candidates[i].symbol;
aee1fcdf 3555 innermost_block.update (candidates[i]);
4c4b4cd2 3556 }
14f9c5c9
AS
3557 }
3558 break;
3559 case BINOP_ADD:
3560 case BINOP_SUB:
3561 case BINOP_MUL:
3562 case BINOP_DIV:
3563 case BINOP_REM:
3564 case BINOP_MOD:
3565 case BINOP_CONCAT:
3566 case BINOP_BITWISE_AND:
3567 case BINOP_BITWISE_IOR:
3568 case BINOP_BITWISE_XOR:
3569 case BINOP_EQUAL:
3570 case BINOP_NOTEQUAL:
3571 case BINOP_LESS:
3572 case BINOP_GTR:
3573 case BINOP_LEQ:
3574 case BINOP_GEQ:
3575 case BINOP_EXP:
3576 case UNOP_NEG:
3577 case UNOP_PLUS:
3578 case UNOP_LOGICAL_NOT:
3579 case UNOP_ABS:
3580 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3581 {
54d343a2 3582 std::vector<struct block_symbol> candidates;
4c4b4cd2
PH
3583 int n_candidates;
3584
3585 n_candidates =
b5ec771e 3586 ada_lookup_symbol_list (ada_decoded_op_name (op),
4c4b4cd2 3587 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3588 &candidates);
ec6a20c2 3589
54d343a2
TT
3590 i = ada_resolve_function (candidates.data (), n_candidates, argvec,
3591 nargs, ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3592 if (i < 0)
3593 break;
3594
d12307c1
PMR
3595 replace_operator_with_call (expp, pc, nargs, 1,
3596 candidates[i].symbol,
3597 candidates[i].block);
e9d9f57e 3598 exp = expp->get ();
4c4b4cd2 3599 }
14f9c5c9 3600 break;
4c4b4cd2
PH
3601
3602 case OP_TYPE:
b3dbf008 3603 case OP_REGISTER:
4c4b4cd2 3604 return NULL;
14f9c5c9
AS
3605 }
3606
3607 *pos = pc;
ced9779b
JB
3608 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3609 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3610 exp->elts[pc + 1].objfile,
3611 exp->elts[pc + 2].msymbol);
3612 else
3613 return evaluate_subexp_type (exp, pos);
14f9c5c9
AS
3614}
3615
3616/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3617 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3618 a non-pointer. */
14f9c5c9 3619/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3620 liberal. */
14f9c5c9
AS
3621
3622static int
4dc81987 3623ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3624{
61ee279c
PH
3625 ftype = ada_check_typedef (ftype);
3626 atype = ada_check_typedef (atype);
14f9c5c9
AS
3627
3628 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3629 ftype = TYPE_TARGET_TYPE (ftype);
3630 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3631 atype = TYPE_TARGET_TYPE (atype);
3632
d2e4a39e 3633 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3634 {
3635 default:
5b3d5b7d 3636 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3637 case TYPE_CODE_PTR:
3638 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3639 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3640 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3641 else
1265e4aa
JB
3642 return (may_deref
3643 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3644 case TYPE_CODE_INT:
3645 case TYPE_CODE_ENUM:
3646 case TYPE_CODE_RANGE:
3647 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3648 {
3649 case TYPE_CODE_INT:
3650 case TYPE_CODE_ENUM:
3651 case TYPE_CODE_RANGE:
3652 return 1;
3653 default:
3654 return 0;
3655 }
14f9c5c9
AS
3656
3657 case TYPE_CODE_ARRAY:
d2e4a39e 3658 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3659 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3660
3661 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3662 if (ada_is_array_descriptor_type (ftype))
3663 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3664 || ada_is_array_descriptor_type (atype));
14f9c5c9 3665 else
4c4b4cd2
PH
3666 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3667 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3668
3669 case TYPE_CODE_UNION:
3670 case TYPE_CODE_FLT:
3671 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3672 }
3673}
3674
3675/* Return non-zero if the formals of FUNC "sufficiently match" the
3676 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3677 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3678 argument function. */
14f9c5c9
AS
3679
3680static int
d2e4a39e 3681ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3682{
3683 int i;
d2e4a39e 3684 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3685
1265e4aa
JB
3686 if (SYMBOL_CLASS (func) == LOC_CONST
3687 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3688 return (n_actuals == 0);
3689 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3690 return 0;
3691
3692 if (TYPE_NFIELDS (func_type) != n_actuals)
3693 return 0;
3694
3695 for (i = 0; i < n_actuals; i += 1)
3696 {
4c4b4cd2 3697 if (actuals[i] == NULL)
76a01679
JB
3698 return 0;
3699 else
3700 {
5b4ee69b
MS
3701 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3702 i));
df407dfe 3703 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3704
76a01679
JB
3705 if (!ada_type_match (ftype, atype, 1))
3706 return 0;
3707 }
14f9c5c9
AS
3708 }
3709 return 1;
3710}
3711
3712/* False iff function type FUNC_TYPE definitely does not produce a value
3713 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3714 FUNC_TYPE is not a valid function type with a non-null return type
3715 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3716
3717static int
d2e4a39e 3718return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3719{
d2e4a39e 3720 struct type *return_type;
14f9c5c9
AS
3721
3722 if (func_type == NULL)
3723 return 1;
3724
4c4b4cd2 3725 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3726 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3727 else
18af8284 3728 return_type = get_base_type (func_type);
14f9c5c9
AS
3729 if (return_type == NULL)
3730 return 1;
3731
18af8284 3732 context_type = get_base_type (context_type);
14f9c5c9
AS
3733
3734 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3735 return context_type == NULL || return_type == context_type;
3736 else if (context_type == NULL)
3737 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3738 else
3739 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3740}
3741
3742
4c4b4cd2 3743/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3744 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3745 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3746 that returns that type, then eliminate matches that don't. If
3747 CONTEXT_TYPE is void and there is at least one match that does not
3748 return void, eliminate all matches that do.
3749
14f9c5c9
AS
3750 Asks the user if there is more than one match remaining. Returns -1
3751 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3752 solely for messages. May re-arrange and modify SYMS in
3753 the process; the index returned is for the modified vector. */
14f9c5c9 3754
4c4b4cd2 3755static int
d12307c1 3756ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3757 int nsyms, struct value **args, int nargs,
3758 const char *name, struct type *context_type)
14f9c5c9 3759{
30b15541 3760 int fallback;
14f9c5c9 3761 int k;
4c4b4cd2 3762 int m; /* Number of hits */
14f9c5c9 3763
d2e4a39e 3764 m = 0;
30b15541
UW
3765 /* In the first pass of the loop, we only accept functions matching
3766 context_type. If none are found, we add a second pass of the loop
3767 where every function is accepted. */
3768 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3769 {
3770 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3771 {
d12307c1 3772 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3773
d12307c1 3774 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3775 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3776 {
3777 syms[m] = syms[k];
3778 m += 1;
3779 }
3780 }
14f9c5c9
AS
3781 }
3782
dc5c8746
PMR
3783 /* If we got multiple matches, ask the user which one to use. Don't do this
3784 interactive thing during completion, though, as the purpose of the
3785 completion is providing a list of all possible matches. Prompting the
3786 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3787 if (m == 0)
3788 return -1;
dc5c8746 3789 else if (m > 1 && !parse_completion)
14f9c5c9 3790 {
323e0a4a 3791 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3792 user_select_syms (syms, m, 1);
14f9c5c9
AS
3793 return 0;
3794 }
3795 return 0;
3796}
3797
4c4b4cd2
PH
3798/* Returns true (non-zero) iff decoded name N0 should appear before N1
3799 in a listing of choices during disambiguation (see sort_choices, below).
3800 The idea is that overloadings of a subprogram name from the
3801 same package should sort in their source order. We settle for ordering
3802 such symbols by their trailing number (__N or $N). */
3803
14f9c5c9 3804static int
0d5cff50 3805encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3806{
3807 if (N1 == NULL)
3808 return 0;
3809 else if (N0 == NULL)
3810 return 1;
3811 else
3812 {
3813 int k0, k1;
5b4ee69b 3814
d2e4a39e 3815 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3816 ;
d2e4a39e 3817 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3818 ;
d2e4a39e 3819 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3820 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3821 {
3822 int n0, n1;
5b4ee69b 3823
4c4b4cd2
PH
3824 n0 = k0;
3825 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3826 n0 -= 1;
3827 n1 = k1;
3828 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3829 n1 -= 1;
3830 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3831 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3832 }
14f9c5c9
AS
3833 return (strcmp (N0, N1) < 0);
3834 }
3835}
d2e4a39e 3836
4c4b4cd2
PH
3837/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3838 encoded names. */
3839
d2e4a39e 3840static void
d12307c1 3841sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3842{
4c4b4cd2 3843 int i;
5b4ee69b 3844
d2e4a39e 3845 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3846 {
d12307c1 3847 struct block_symbol sym = syms[i];
14f9c5c9
AS
3848 int j;
3849
d2e4a39e 3850 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3851 {
d12307c1
PMR
3852 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3853 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3854 break;
3855 syms[j + 1] = syms[j];
3856 }
d2e4a39e 3857 syms[j + 1] = sym;
14f9c5c9
AS
3858 }
3859}
3860
d72413e6
PMR
3861/* Whether GDB should display formals and return types for functions in the
3862 overloads selection menu. */
3863static int print_signatures = 1;
3864
3865/* Print the signature for SYM on STREAM according to the FLAGS options. For
3866 all but functions, the signature is just the name of the symbol. For
3867 functions, this is the name of the function, the list of types for formals
3868 and the return type (if any). */
3869
3870static void
3871ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3872 const struct type_print_options *flags)
3873{
3874 struct type *type = SYMBOL_TYPE (sym);
3875
3876 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3877 if (!print_signatures
3878 || type == NULL
3879 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3880 return;
3881
3882 if (TYPE_NFIELDS (type) > 0)
3883 {
3884 int i;
3885
3886 fprintf_filtered (stream, " (");
3887 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3888 {
3889 if (i > 0)
3890 fprintf_filtered (stream, "; ");
3891 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3892 flags);
3893 }
3894 fprintf_filtered (stream, ")");
3895 }
3896 if (TYPE_TARGET_TYPE (type) != NULL
3897 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3898 {
3899 fprintf_filtered (stream, " return ");
3900 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3901 }
3902}
3903
4c4b4cd2
PH
3904/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3905 by asking the user (if necessary), returning the number selected,
3906 and setting the first elements of SYMS items. Error if no symbols
3907 selected. */
14f9c5c9
AS
3908
3909/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3910 to be re-integrated one of these days. */
14f9c5c9
AS
3911
3912int
d12307c1 3913user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3914{
3915 int i;
8d749320 3916 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3917 int n_chosen;
3918 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3919 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3920
3921 if (max_results < 1)
323e0a4a 3922 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3923 if (nsyms <= 1)
3924 return nsyms;
3925
717d2f5a
JB
3926 if (select_mode == multiple_symbols_cancel)
3927 error (_("\
3928canceled because the command is ambiguous\n\
3929See set/show multiple-symbol."));
3930
3931 /* If select_mode is "all", then return all possible symbols.
3932 Only do that if more than one symbol can be selected, of course.
3933 Otherwise, display the menu as usual. */
3934 if (select_mode == multiple_symbols_all && max_results > 1)
3935 return nsyms;
3936
323e0a4a 3937 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3938 if (max_results > 1)
323e0a4a 3939 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3940
4c4b4cd2 3941 sort_choices (syms, nsyms);
14f9c5c9
AS
3942
3943 for (i = 0; i < nsyms; i += 1)
3944 {
d12307c1 3945 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3946 continue;
3947
d12307c1 3948 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3949 {
76a01679 3950 struct symtab_and_line sal =
d12307c1 3951 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3952
d72413e6
PMR
3953 printf_unfiltered ("[%d] ", i + first_choice);
3954 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3955 &type_print_raw_options);
323e0a4a 3956 if (sal.symtab == NULL)
d72413e6 3957 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3958 sal.line);
3959 else
d72413e6 3960 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3961 symtab_to_filename_for_display (sal.symtab),
3962 sal.line);
4c4b4cd2
PH
3963 continue;
3964 }
d2e4a39e 3965 else
4c4b4cd2
PH
3966 {
3967 int is_enumeral =
d12307c1
PMR
3968 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3969 && SYMBOL_TYPE (syms[i].symbol) != NULL
3970 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3971 struct symtab *symtab = NULL;
3972
d12307c1
PMR
3973 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3974 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3975
d12307c1 3976 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3977 {
3978 printf_unfiltered ("[%d] ", i + first_choice);
3979 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3980 &type_print_raw_options);
3981 printf_unfiltered (_(" at %s:%d\n"),
3982 symtab_to_filename_for_display (symtab),
3983 SYMBOL_LINE (syms[i].symbol));
3984 }
76a01679 3985 else if (is_enumeral
d12307c1 3986 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3987 {
a3f17187 3988 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3989 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3990 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3991 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3992 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3993 }
d72413e6
PMR
3994 else
3995 {
3996 printf_unfiltered ("[%d] ", i + first_choice);
3997 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3998 &type_print_raw_options);
3999
4000 if (symtab != NULL)
4001 printf_unfiltered (is_enumeral
4002 ? _(" in %s (enumeral)\n")
4003 : _(" at %s:?\n"),
4004 symtab_to_filename_for_display (symtab));
4005 else
4006 printf_unfiltered (is_enumeral
4007 ? _(" (enumeral)\n")
4008 : _(" at ?\n"));
4009 }
4c4b4cd2 4010 }
14f9c5c9 4011 }
d2e4a39e 4012
14f9c5c9 4013 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4014 "overload-choice");
14f9c5c9
AS
4015
4016 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4017 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4018
4019 return n_chosen;
4020}
4021
4022/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4023 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4024 order in CHOICES[0 .. N-1], and return N.
4025
4026 The user types choices as a sequence of numbers on one line
4027 separated by blanks, encoding them as follows:
4028
4c4b4cd2 4029 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4030 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4031 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4032
4c4b4cd2 4033 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4034
4035 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4036 prompts (for use with the -f switch). */
14f9c5c9
AS
4037
4038int
d2e4a39e 4039get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4040 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4041{
d2e4a39e 4042 char *args;
a121b7c1 4043 const char *prompt;
14f9c5c9
AS
4044 int n_chosen;
4045 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4046
14f9c5c9
AS
4047 prompt = getenv ("PS2");
4048 if (prompt == NULL)
0bcd0149 4049 prompt = "> ";
14f9c5c9 4050
89fbedf3 4051 args = command_line_input (prompt, annotation_suffix);
d2e4a39e 4052
14f9c5c9 4053 if (args == NULL)
323e0a4a 4054 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4055
4056 n_chosen = 0;
76a01679 4057
4c4b4cd2
PH
4058 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4059 order, as given in args. Choices are validated. */
14f9c5c9
AS
4060 while (1)
4061 {
d2e4a39e 4062 char *args2;
14f9c5c9
AS
4063 int choice, j;
4064
0fcd72ba 4065 args = skip_spaces (args);
14f9c5c9 4066 if (*args == '\0' && n_chosen == 0)
323e0a4a 4067 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4068 else if (*args == '\0')
4c4b4cd2 4069 break;
14f9c5c9
AS
4070
4071 choice = strtol (args, &args2, 10);
d2e4a39e 4072 if (args == args2 || choice < 0
4c4b4cd2 4073 || choice > n_choices + first_choice - 1)
323e0a4a 4074 error (_("Argument must be choice number"));
14f9c5c9
AS
4075 args = args2;
4076
d2e4a39e 4077 if (choice == 0)
323e0a4a 4078 error (_("cancelled"));
14f9c5c9
AS
4079
4080 if (choice < first_choice)
4c4b4cd2
PH
4081 {
4082 n_chosen = n_choices;
4083 for (j = 0; j < n_choices; j += 1)
4084 choices[j] = j;
4085 break;
4086 }
14f9c5c9
AS
4087 choice -= first_choice;
4088
d2e4a39e 4089 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4090 {
4091 }
14f9c5c9
AS
4092
4093 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4094 {
4095 int k;
5b4ee69b 4096
4c4b4cd2
PH
4097 for (k = n_chosen - 1; k > j; k -= 1)
4098 choices[k + 1] = choices[k];
4099 choices[j + 1] = choice;
4100 n_chosen += 1;
4101 }
14f9c5c9
AS
4102 }
4103
4104 if (n_chosen > max_results)
323e0a4a 4105 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4106
14f9c5c9
AS
4107 return n_chosen;
4108}
4109
4c4b4cd2
PH
4110/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4111 on the function identified by SYM and BLOCK, and taking NARGS
4112 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4113
4114static void
e9d9f57e 4115replace_operator_with_call (expression_up *expp, int pc, int nargs,
4c4b4cd2 4116 int oplen, struct symbol *sym,
270140bd 4117 const struct block *block)
14f9c5c9
AS
4118{
4119 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4120 symbol, -oplen for operator being replaced). */
d2e4a39e 4121 struct expression *newexp = (struct expression *)
8c1a34e7 4122 xzalloc (sizeof (struct expression)
4c4b4cd2 4123 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
e9d9f57e 4124 struct expression *exp = expp->get ();
14f9c5c9
AS
4125
4126 newexp->nelts = exp->nelts + 7 - oplen;
4127 newexp->language_defn = exp->language_defn;
3489610d 4128 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4129 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4130 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4131 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4132
4133 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4134 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4135
4136 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4137 newexp->elts[pc + 4].block = block;
4138 newexp->elts[pc + 5].symbol = sym;
4139
e9d9f57e 4140 expp->reset (newexp);
d2e4a39e 4141}
14f9c5c9
AS
4142
4143/* Type-class predicates */
4144
4c4b4cd2
PH
4145/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4146 or FLOAT). */
14f9c5c9
AS
4147
4148static int
d2e4a39e 4149numeric_type_p (struct type *type)
14f9c5c9
AS
4150{
4151 if (type == NULL)
4152 return 0;
d2e4a39e
AS
4153 else
4154 {
4155 switch (TYPE_CODE (type))
4c4b4cd2
PH
4156 {
4157 case TYPE_CODE_INT:
4158 case TYPE_CODE_FLT:
4159 return 1;
4160 case TYPE_CODE_RANGE:
4161 return (type == TYPE_TARGET_TYPE (type)
4162 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4163 default:
4164 return 0;
4165 }
d2e4a39e 4166 }
14f9c5c9
AS
4167}
4168
4c4b4cd2 4169/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4170
4171static int
d2e4a39e 4172integer_type_p (struct type *type)
14f9c5c9
AS
4173{
4174 if (type == NULL)
4175 return 0;
d2e4a39e
AS
4176 else
4177 {
4178 switch (TYPE_CODE (type))
4c4b4cd2
PH
4179 {
4180 case TYPE_CODE_INT:
4181 return 1;
4182 case TYPE_CODE_RANGE:
4183 return (type == TYPE_TARGET_TYPE (type)
4184 || integer_type_p (TYPE_TARGET_TYPE (type)));
4185 default:
4186 return 0;
4187 }
d2e4a39e 4188 }
14f9c5c9
AS
4189}
4190
4c4b4cd2 4191/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4192
4193static int
d2e4a39e 4194scalar_type_p (struct type *type)
14f9c5c9
AS
4195{
4196 if (type == NULL)
4197 return 0;
d2e4a39e
AS
4198 else
4199 {
4200 switch (TYPE_CODE (type))
4c4b4cd2
PH
4201 {
4202 case TYPE_CODE_INT:
4203 case TYPE_CODE_RANGE:
4204 case TYPE_CODE_ENUM:
4205 case TYPE_CODE_FLT:
4206 return 1;
4207 default:
4208 return 0;
4209 }
d2e4a39e 4210 }
14f9c5c9
AS
4211}
4212
4c4b4cd2 4213/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4214
4215static int
d2e4a39e 4216discrete_type_p (struct type *type)
14f9c5c9
AS
4217{
4218 if (type == NULL)
4219 return 0;
d2e4a39e
AS
4220 else
4221 {
4222 switch (TYPE_CODE (type))
4c4b4cd2
PH
4223 {
4224 case TYPE_CODE_INT:
4225 case TYPE_CODE_RANGE:
4226 case TYPE_CODE_ENUM:
872f0337 4227 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4228 return 1;
4229 default:
4230 return 0;
4231 }
d2e4a39e 4232 }
14f9c5c9
AS
4233}
4234
4c4b4cd2
PH
4235/* Returns non-zero if OP with operands in the vector ARGS could be
4236 a user-defined function. Errs on the side of pre-defined operators
4237 (i.e., result 0). */
14f9c5c9
AS
4238
4239static int
d2e4a39e 4240possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4241{
76a01679 4242 struct type *type0 =
df407dfe 4243 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4244 struct type *type1 =
df407dfe 4245 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4246
4c4b4cd2
PH
4247 if (type0 == NULL)
4248 return 0;
4249
14f9c5c9
AS
4250 switch (op)
4251 {
4252 default:
4253 return 0;
4254
4255 case BINOP_ADD:
4256 case BINOP_SUB:
4257 case BINOP_MUL:
4258 case BINOP_DIV:
d2e4a39e 4259 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4260
4261 case BINOP_REM:
4262 case BINOP_MOD:
4263 case BINOP_BITWISE_AND:
4264 case BINOP_BITWISE_IOR:
4265 case BINOP_BITWISE_XOR:
d2e4a39e 4266 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4267
4268 case BINOP_EQUAL:
4269 case BINOP_NOTEQUAL:
4270 case BINOP_LESS:
4271 case BINOP_GTR:
4272 case BINOP_LEQ:
4273 case BINOP_GEQ:
d2e4a39e 4274 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4275
4276 case BINOP_CONCAT:
ee90b9ab 4277 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4278
4279 case BINOP_EXP:
d2e4a39e 4280 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4281
4282 case UNOP_NEG:
4283 case UNOP_PLUS:
4284 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4285 case UNOP_ABS:
4286 return (!numeric_type_p (type0));
14f9c5c9
AS
4287
4288 }
4289}
4290\f
4c4b4cd2 4291 /* Renaming */
14f9c5c9 4292
aeb5907d
JB
4293/* NOTES:
4294
4295 1. In the following, we assume that a renaming type's name may
4296 have an ___XD suffix. It would be nice if this went away at some
4297 point.
4298 2. We handle both the (old) purely type-based representation of
4299 renamings and the (new) variable-based encoding. At some point,
4300 it is devoutly to be hoped that the former goes away
4301 (FIXME: hilfinger-2007-07-09).
4302 3. Subprogram renamings are not implemented, although the XRS
4303 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4304
4305/* If SYM encodes a renaming,
4306
4307 <renaming> renames <renamed entity>,
4308
4309 sets *LEN to the length of the renamed entity's name,
4310 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4311 the string describing the subcomponent selected from the renamed
0963b4bd 4312 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4313 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4314 are undefined). Otherwise, returns a value indicating the category
4315 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4316 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4317 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4318 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4319 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4320 may be NULL, in which case they are not assigned.
4321
4322 [Currently, however, GCC does not generate subprogram renamings.] */
4323
4324enum ada_renaming_category
4325ada_parse_renaming (struct symbol *sym,
4326 const char **renamed_entity, int *len,
4327 const char **renaming_expr)
4328{
4329 enum ada_renaming_category kind;
4330 const char *info;
4331 const char *suffix;
4332
4333 if (sym == NULL)
4334 return ADA_NOT_RENAMING;
4335 switch (SYMBOL_CLASS (sym))
14f9c5c9 4336 {
aeb5907d
JB
4337 default:
4338 return ADA_NOT_RENAMING;
4339 case LOC_TYPEDEF:
4340 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4341 renamed_entity, len, renaming_expr);
4342 case LOC_LOCAL:
4343 case LOC_STATIC:
4344 case LOC_COMPUTED:
4345 case LOC_OPTIMIZED_OUT:
4346 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4347 if (info == NULL)
4348 return ADA_NOT_RENAMING;
4349 switch (info[5])
4350 {
4351 case '_':
4352 kind = ADA_OBJECT_RENAMING;
4353 info += 6;
4354 break;
4355 case 'E':
4356 kind = ADA_EXCEPTION_RENAMING;
4357 info += 7;
4358 break;
4359 case 'P':
4360 kind = ADA_PACKAGE_RENAMING;
4361 info += 7;
4362 break;
4363 case 'S':
4364 kind = ADA_SUBPROGRAM_RENAMING;
4365 info += 7;
4366 break;
4367 default:
4368 return ADA_NOT_RENAMING;
4369 }
14f9c5c9 4370 }
4c4b4cd2 4371
aeb5907d
JB
4372 if (renamed_entity != NULL)
4373 *renamed_entity = info;
4374 suffix = strstr (info, "___XE");
4375 if (suffix == NULL || suffix == info)
4376 return ADA_NOT_RENAMING;
4377 if (len != NULL)
4378 *len = strlen (info) - strlen (suffix);
4379 suffix += 5;
4380 if (renaming_expr != NULL)
4381 *renaming_expr = suffix;
4382 return kind;
4383}
4384
4385/* Assuming TYPE encodes a renaming according to the old encoding in
4386 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4387 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4388 ADA_NOT_RENAMING otherwise. */
4389static enum ada_renaming_category
4390parse_old_style_renaming (struct type *type,
4391 const char **renamed_entity, int *len,
4392 const char **renaming_expr)
4393{
4394 enum ada_renaming_category kind;
4395 const char *name;
4396 const char *info;
4397 const char *suffix;
14f9c5c9 4398
aeb5907d
JB
4399 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4400 || TYPE_NFIELDS (type) != 1)
4401 return ADA_NOT_RENAMING;
14f9c5c9 4402
a737d952 4403 name = TYPE_NAME (type);
aeb5907d
JB
4404 if (name == NULL)
4405 return ADA_NOT_RENAMING;
4406
4407 name = strstr (name, "___XR");
4408 if (name == NULL)
4409 return ADA_NOT_RENAMING;
4410 switch (name[5])
4411 {
4412 case '\0':
4413 case '_':
4414 kind = ADA_OBJECT_RENAMING;
4415 break;
4416 case 'E':
4417 kind = ADA_EXCEPTION_RENAMING;
4418 break;
4419 case 'P':
4420 kind = ADA_PACKAGE_RENAMING;
4421 break;
4422 case 'S':
4423 kind = ADA_SUBPROGRAM_RENAMING;
4424 break;
4425 default:
4426 return ADA_NOT_RENAMING;
4427 }
14f9c5c9 4428
aeb5907d
JB
4429 info = TYPE_FIELD_NAME (type, 0);
4430 if (info == NULL)
4431 return ADA_NOT_RENAMING;
4432 if (renamed_entity != NULL)
4433 *renamed_entity = info;
4434 suffix = strstr (info, "___XE");
4435 if (renaming_expr != NULL)
4436 *renaming_expr = suffix + 5;
4437 if (suffix == NULL || suffix == info)
4438 return ADA_NOT_RENAMING;
4439 if (len != NULL)
4440 *len = suffix - info;
4441 return kind;
a5ee536b
JB
4442}
4443
4444/* Compute the value of the given RENAMING_SYM, which is expected to
4445 be a symbol encoding a renaming expression. BLOCK is the block
4446 used to evaluate the renaming. */
52ce6436 4447
a5ee536b
JB
4448static struct value *
4449ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4450 const struct block *block)
a5ee536b 4451{
bbc13ae3 4452 const char *sym_name;
a5ee536b 4453
bbc13ae3 4454 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4455 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4456 return evaluate_expression (expr.get ());
a5ee536b 4457}
14f9c5c9 4458\f
d2e4a39e 4459
4c4b4cd2 4460 /* Evaluation: Function Calls */
14f9c5c9 4461
4c4b4cd2 4462/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4463 lvalues, and otherwise has the side-effect of allocating memory
4464 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4465
d2e4a39e 4466static struct value *
40bc484c 4467ensure_lval (struct value *val)
14f9c5c9 4468{
40bc484c
JB
4469 if (VALUE_LVAL (val) == not_lval
4470 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4471 {
df407dfe 4472 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4473 const CORE_ADDR addr =
4474 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4475
a84a8a0d 4476 VALUE_LVAL (val) = lval_memory;
1a088441 4477 set_value_address (val, addr);
40bc484c 4478 write_memory (addr, value_contents (val), len);
c3e5cd34 4479 }
14f9c5c9
AS
4480
4481 return val;
4482}
4483
4484/* Return the value ACTUAL, converted to be an appropriate value for a
4485 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4486 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4487 values not residing in memory, updating it as needed. */
14f9c5c9 4488
a93c0eb6 4489struct value *
40bc484c 4490ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4491{
df407dfe 4492 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4493 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4494 struct type *formal_target =
4495 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4496 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4497 struct type *actual_target =
4498 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4499 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4500
4c4b4cd2 4501 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4502 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4503 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4504 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4505 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4506 {
a84a8a0d 4507 struct value *result;
5b4ee69b 4508
14f9c5c9 4509 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4510 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4511 result = desc_data (actual);
cb923fcc 4512 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4513 {
4514 if (VALUE_LVAL (actual) != lval_memory)
4515 {
4516 struct value *val;
5b4ee69b 4517
df407dfe 4518 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4519 val = allocate_value (actual_type);
990a07ab 4520 memcpy ((char *) value_contents_raw (val),
0fd88904 4521 (char *) value_contents (actual),
4c4b4cd2 4522 TYPE_LENGTH (actual_type));
40bc484c 4523 actual = ensure_lval (val);
4c4b4cd2 4524 }
a84a8a0d 4525 result = value_addr (actual);
4c4b4cd2 4526 }
a84a8a0d
JB
4527 else
4528 return actual;
b1af9e97 4529 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4530 }
4531 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4532 return ada_value_ind (actual);
8344af1e
JB
4533 else if (ada_is_aligner_type (formal_type))
4534 {
4535 /* We need to turn this parameter into an aligner type
4536 as well. */
4537 struct value *aligner = allocate_value (formal_type);
4538 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4539
4540 value_assign_to_component (aligner, component, actual);
4541 return aligner;
4542 }
14f9c5c9
AS
4543
4544 return actual;
4545}
4546
438c98a1
JB
4547/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4548 type TYPE. This is usually an inefficient no-op except on some targets
4549 (such as AVR) where the representation of a pointer and an address
4550 differs. */
4551
4552static CORE_ADDR
4553value_pointer (struct value *value, struct type *type)
4554{
4555 struct gdbarch *gdbarch = get_type_arch (type);
4556 unsigned len = TYPE_LENGTH (type);
224c3ddb 4557 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4558 CORE_ADDR addr;
4559
4560 addr = value_address (value);
4561 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4562 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4563 return addr;
4564}
4565
14f9c5c9 4566
4c4b4cd2
PH
4567/* Push a descriptor of type TYPE for array value ARR on the stack at
4568 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4569 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4570 to-descriptor type rather than a descriptor type), a struct value *
4571 representing a pointer to this descriptor. */
14f9c5c9 4572
d2e4a39e 4573static struct value *
40bc484c 4574make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4575{
d2e4a39e
AS
4576 struct type *bounds_type = desc_bounds_type (type);
4577 struct type *desc_type = desc_base_type (type);
4578 struct value *descriptor = allocate_value (desc_type);
4579 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4580 int i;
d2e4a39e 4581
0963b4bd
MS
4582 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4583 i > 0; i -= 1)
14f9c5c9 4584 {
19f220c3
JK
4585 modify_field (value_type (bounds), value_contents_writeable (bounds),
4586 ada_array_bound (arr, i, 0),
4587 desc_bound_bitpos (bounds_type, i, 0),
4588 desc_bound_bitsize (bounds_type, i, 0));
4589 modify_field (value_type (bounds), value_contents_writeable (bounds),
4590 ada_array_bound (arr, i, 1),
4591 desc_bound_bitpos (bounds_type, i, 1),
4592 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4593 }
d2e4a39e 4594
40bc484c 4595 bounds = ensure_lval (bounds);
d2e4a39e 4596
19f220c3
JK
4597 modify_field (value_type (descriptor),
4598 value_contents_writeable (descriptor),
4599 value_pointer (ensure_lval (arr),
4600 TYPE_FIELD_TYPE (desc_type, 0)),
4601 fat_pntr_data_bitpos (desc_type),
4602 fat_pntr_data_bitsize (desc_type));
4603
4604 modify_field (value_type (descriptor),
4605 value_contents_writeable (descriptor),
4606 value_pointer (bounds,
4607 TYPE_FIELD_TYPE (desc_type, 1)),
4608 fat_pntr_bounds_bitpos (desc_type),
4609 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4610
40bc484c 4611 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4612
4613 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4614 return value_addr (descriptor);
4615 else
4616 return descriptor;
4617}
14f9c5c9 4618\f
3d9434b5
JB
4619 /* Symbol Cache Module */
4620
3d9434b5 4621/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4622 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4623 on the type of entity being printed, the cache can make it as much
4624 as an order of magnitude faster than without it.
4625
4626 The descriptive type DWARF extension has significantly reduced
4627 the need for this cache, at least when DWARF is being used. However,
4628 even in this case, some expensive name-based symbol searches are still
4629 sometimes necessary - to find an XVZ variable, mostly. */
4630
ee01b665 4631/* Initialize the contents of SYM_CACHE. */
3d9434b5 4632
ee01b665
JB
4633static void
4634ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4635{
4636 obstack_init (&sym_cache->cache_space);
4637 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4638}
3d9434b5 4639
ee01b665
JB
4640/* Free the memory used by SYM_CACHE. */
4641
4642static void
4643ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4644{
ee01b665
JB
4645 obstack_free (&sym_cache->cache_space, NULL);
4646 xfree (sym_cache);
4647}
3d9434b5 4648
ee01b665
JB
4649/* Return the symbol cache associated to the given program space PSPACE.
4650 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4651
ee01b665
JB
4652static struct ada_symbol_cache *
4653ada_get_symbol_cache (struct program_space *pspace)
4654{
4655 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4656
66c168ae 4657 if (pspace_data->sym_cache == NULL)
ee01b665 4658 {
66c168ae
JB
4659 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4660 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4661 }
4662
66c168ae 4663 return pspace_data->sym_cache;
ee01b665 4664}
3d9434b5
JB
4665
4666/* Clear all entries from the symbol cache. */
4667
4668static void
4669ada_clear_symbol_cache (void)
4670{
ee01b665
JB
4671 struct ada_symbol_cache *sym_cache
4672 = ada_get_symbol_cache (current_program_space);
4673
4674 obstack_free (&sym_cache->cache_space, NULL);
4675 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4676}
4677
fe978cb0 4678/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4679 Return it if found, or NULL otherwise. */
4680
4681static struct cache_entry **
fe978cb0 4682find_entry (const char *name, domain_enum domain)
3d9434b5 4683{
ee01b665
JB
4684 struct ada_symbol_cache *sym_cache
4685 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4686 int h = msymbol_hash (name) % HASH_SIZE;
4687 struct cache_entry **e;
4688
ee01b665 4689 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4690 {
fe978cb0 4691 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4692 return e;
4693 }
4694 return NULL;
4695}
4696
fe978cb0 4697/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4698 Return 1 if found, 0 otherwise.
4699
4700 If an entry was found and SYM is not NULL, set *SYM to the entry's
4701 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4702
96d887e8 4703static int
fe978cb0 4704lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4705 struct symbol **sym, const struct block **block)
96d887e8 4706{
fe978cb0 4707 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4708
4709 if (e == NULL)
4710 return 0;
4711 if (sym != NULL)
4712 *sym = (*e)->sym;
4713 if (block != NULL)
4714 *block = (*e)->block;
4715 return 1;
96d887e8
PH
4716}
4717
3d9434b5 4718/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4719 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4720
96d887e8 4721static void
fe978cb0 4722cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4723 const struct block *block)
96d887e8 4724{
ee01b665
JB
4725 struct ada_symbol_cache *sym_cache
4726 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4727 int h;
4728 char *copy;
4729 struct cache_entry *e;
4730
1994afbf
DE
4731 /* Symbols for builtin types don't have a block.
4732 For now don't cache such symbols. */
4733 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4734 return;
4735
3d9434b5
JB
4736 /* If the symbol is a local symbol, then do not cache it, as a search
4737 for that symbol depends on the context. To determine whether
4738 the symbol is local or not, we check the block where we found it
4739 against the global and static blocks of its associated symtab. */
4740 if (sym
08be3fe3 4741 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4742 GLOBAL_BLOCK) != block
08be3fe3 4743 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4744 STATIC_BLOCK) != block)
3d9434b5
JB
4745 return;
4746
4747 h = msymbol_hash (name) % HASH_SIZE;
e39db4db 4748 e = XOBNEW (&sym_cache->cache_space, cache_entry);
ee01b665
JB
4749 e->next = sym_cache->root[h];
4750 sym_cache->root[h] = e;
224c3ddb
SM
4751 e->name = copy
4752 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4753 strcpy (copy, name);
4754 e->sym = sym;
fe978cb0 4755 e->domain = domain;
3d9434b5 4756 e->block = block;
96d887e8 4757}
4c4b4cd2
PH
4758\f
4759 /* Symbol Lookup */
4760
b5ec771e
PA
4761/* Return the symbol name match type that should be used used when
4762 searching for all symbols matching LOOKUP_NAME.
c0431670
JB
4763
4764 LOOKUP_NAME is expected to be a symbol name after transformation
f98b2e33 4765 for Ada lookups. */
c0431670 4766
b5ec771e
PA
4767static symbol_name_match_type
4768name_match_type_from_name (const char *lookup_name)
c0431670 4769{
b5ec771e
PA
4770 return (strstr (lookup_name, "__") == NULL
4771 ? symbol_name_match_type::WILD
4772 : symbol_name_match_type::FULL);
c0431670
JB
4773}
4774
4c4b4cd2
PH
4775/* Return the result of a standard (literal, C-like) lookup of NAME in
4776 given DOMAIN, visible from lexical block BLOCK. */
4777
4778static struct symbol *
4779standard_lookup (const char *name, const struct block *block,
4780 domain_enum domain)
4781{
acbd605d 4782 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4783 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4784
d12307c1
PMR
4785 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4786 return sym.symbol;
2570f2b7 4787 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4788 cache_symbol (name, domain, sym.symbol, sym.block);
4789 return sym.symbol;
4c4b4cd2
PH
4790}
4791
4792
4793/* Non-zero iff there is at least one non-function/non-enumeral symbol
4794 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4795 since they contend in overloading in the same way. */
4796static int
d12307c1 4797is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4798{
4799 int i;
4800
4801 for (i = 0; i < n; i += 1)
d12307c1
PMR
4802 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4803 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4804 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4805 return 1;
4806
4807 return 0;
4808}
4809
4810/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4811 struct types. Otherwise, they may not. */
14f9c5c9
AS
4812
4813static int
d2e4a39e 4814equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4815{
d2e4a39e 4816 if (type0 == type1)
14f9c5c9 4817 return 1;
d2e4a39e 4818 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4819 || TYPE_CODE (type0) != TYPE_CODE (type1))
4820 return 0;
d2e4a39e 4821 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4822 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4823 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4824 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4825 return 1;
d2e4a39e 4826
14f9c5c9
AS
4827 return 0;
4828}
4829
4830/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4831 no more defined than that of SYM1. */
14f9c5c9
AS
4832
4833static int
d2e4a39e 4834lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4835{
4836 if (sym0 == sym1)
4837 return 1;
176620f1 4838 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4839 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4840 return 0;
4841
d2e4a39e 4842 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4843 {
4844 case LOC_UNDEF:
4845 return 1;
4846 case LOC_TYPEDEF:
4847 {
4c4b4cd2
PH
4848 struct type *type0 = SYMBOL_TYPE (sym0);
4849 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4850 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4851 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4852 int len0 = strlen (name0);
5b4ee69b 4853
4c4b4cd2
PH
4854 return
4855 TYPE_CODE (type0) == TYPE_CODE (type1)
4856 && (equiv_types (type0, type1)
4857 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4858 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4859 }
4860 case LOC_CONST:
4861 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4862 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4863 default:
4864 return 0;
14f9c5c9
AS
4865 }
4866}
4867
d12307c1 4868/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4869 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4870
4871static void
76a01679
JB
4872add_defn_to_vec (struct obstack *obstackp,
4873 struct symbol *sym,
f0c5f9b2 4874 const struct block *block)
14f9c5c9
AS
4875{
4876 int i;
d12307c1 4877 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4878
529cad9c
PH
4879 /* Do not try to complete stub types, as the debugger is probably
4880 already scanning all symbols matching a certain name at the
4881 time when this function is called. Trying to replace the stub
4882 type by its associated full type will cause us to restart a scan
4883 which may lead to an infinite recursion. Instead, the client
4884 collecting the matching symbols will end up collecting several
4885 matches, with at least one of them complete. It can then filter
4886 out the stub ones if needed. */
4887
4c4b4cd2
PH
4888 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4889 {
d12307c1 4890 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4891 return;
d12307c1 4892 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4893 {
d12307c1 4894 prevDefns[i].symbol = sym;
4c4b4cd2 4895 prevDefns[i].block = block;
4c4b4cd2 4896 return;
76a01679 4897 }
4c4b4cd2
PH
4898 }
4899
4900 {
d12307c1 4901 struct block_symbol info;
4c4b4cd2 4902
d12307c1 4903 info.symbol = sym;
4c4b4cd2 4904 info.block = block;
d12307c1 4905 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4906 }
4907}
4908
d12307c1
PMR
4909/* Number of block_symbol structures currently collected in current vector in
4910 OBSTACKP. */
4c4b4cd2 4911
76a01679
JB
4912static int
4913num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4914{
d12307c1 4915 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4916}
4917
d12307c1
PMR
4918/* Vector of block_symbol structures currently collected in current vector in
4919 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4920
d12307c1 4921static struct block_symbol *
4c4b4cd2
PH
4922defns_collected (struct obstack *obstackp, int finish)
4923{
4924 if (finish)
224c3ddb 4925 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4926 else
d12307c1 4927 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4928}
4929
7c7b6655
TT
4930/* Return a bound minimal symbol matching NAME according to Ada
4931 decoding rules. Returns an invalid symbol if there is no such
4932 minimal symbol. Names prefixed with "standard__" are handled
4933 specially: "standard__" is first stripped off, and only static and
4934 global symbols are searched. */
4c4b4cd2 4935
7c7b6655 4936struct bound_minimal_symbol
96d887e8 4937ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4938{
7c7b6655 4939 struct bound_minimal_symbol result;
4c4b4cd2 4940 struct objfile *objfile;
96d887e8 4941 struct minimal_symbol *msymbol;
4c4b4cd2 4942
7c7b6655
TT
4943 memset (&result, 0, sizeof (result));
4944
b5ec771e
PA
4945 symbol_name_match_type match_type = name_match_type_from_name (name);
4946 lookup_name_info lookup_name (name, match_type);
4947
4948 symbol_name_matcher_ftype *match_name
4949 = ada_get_symbol_name_matcher (lookup_name);
4c4b4cd2 4950
96d887e8
PH
4951 ALL_MSYMBOLS (objfile, msymbol)
4952 {
b5ec771e 4953 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
96d887e8 4954 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4955 {
4956 result.minsym = msymbol;
4957 result.objfile = objfile;
4958 break;
4959 }
96d887e8 4960 }
4c4b4cd2 4961
7c7b6655 4962 return result;
96d887e8 4963}
4c4b4cd2 4964
96d887e8
PH
4965/* For all subprograms that statically enclose the subprogram of the
4966 selected frame, add symbols matching identifier NAME in DOMAIN
4967 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4968 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4969 with a wildcard prefix. */
4c4b4cd2 4970
96d887e8
PH
4971static void
4972add_symbols_from_enclosing_procs (struct obstack *obstackp,
b5ec771e
PA
4973 const lookup_name_info &lookup_name,
4974 domain_enum domain)
96d887e8 4975{
96d887e8 4976}
14f9c5c9 4977
96d887e8
PH
4978/* True if TYPE is definitely an artificial type supplied to a symbol
4979 for which no debugging information was given in the symbol file. */
14f9c5c9 4980
96d887e8
PH
4981static int
4982is_nondebugging_type (struct type *type)
4983{
0d5cff50 4984 const char *name = ada_type_name (type);
5b4ee69b 4985
96d887e8
PH
4986 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4987}
4c4b4cd2 4988
8f17729f
JB
4989/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4990 that are deemed "identical" for practical purposes.
4991
4992 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4993 types and that their number of enumerals is identical (in other
4994 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4995
4996static int
4997ada_identical_enum_types_p (struct type *type1, struct type *type2)
4998{
4999 int i;
5000
5001 /* The heuristic we use here is fairly conservative. We consider
5002 that 2 enumerate types are identical if they have the same
5003 number of enumerals and that all enumerals have the same
5004 underlying value and name. */
5005
5006 /* All enums in the type should have an identical underlying value. */
5007 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 5008 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
5009 return 0;
5010
5011 /* All enumerals should also have the same name (modulo any numerical
5012 suffix). */
5013 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5014 {
0d5cff50
DE
5015 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5016 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5017 int len_1 = strlen (name_1);
5018 int len_2 = strlen (name_2);
5019
5020 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5021 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5022 if (len_1 != len_2
5023 || strncmp (TYPE_FIELD_NAME (type1, i),
5024 TYPE_FIELD_NAME (type2, i),
5025 len_1) != 0)
5026 return 0;
5027 }
5028
5029 return 1;
5030}
5031
5032/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5033 that are deemed "identical" for practical purposes. Sometimes,
5034 enumerals are not strictly identical, but their types are so similar
5035 that they can be considered identical.
5036
5037 For instance, consider the following code:
5038
5039 type Color is (Black, Red, Green, Blue, White);
5040 type RGB_Color is new Color range Red .. Blue;
5041
5042 Type RGB_Color is a subrange of an implicit type which is a copy
5043 of type Color. If we call that implicit type RGB_ColorB ("B" is
5044 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5045 As a result, when an expression references any of the enumeral
5046 by name (Eg. "print green"), the expression is technically
5047 ambiguous and the user should be asked to disambiguate. But
5048 doing so would only hinder the user, since it wouldn't matter
5049 what choice he makes, the outcome would always be the same.
5050 So, for practical purposes, we consider them as the same. */
5051
5052static int
54d343a2 5053symbols_are_identical_enums (const std::vector<struct block_symbol> &syms)
8f17729f
JB
5054{
5055 int i;
5056
5057 /* Before performing a thorough comparison check of each type,
5058 we perform a series of inexpensive checks. We expect that these
5059 checks will quickly fail in the vast majority of cases, and thus
5060 help prevent the unnecessary use of a more expensive comparison.
5061 Said comparison also expects us to make some of these checks
5062 (see ada_identical_enum_types_p). */
5063
5064 /* Quick check: All symbols should have an enum type. */
54d343a2 5065 for (i = 0; i < syms.size (); i++)
d12307c1 5066 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5067 return 0;
5068
5069 /* Quick check: They should all have the same value. */
54d343a2 5070 for (i = 1; i < syms.size (); i++)
d12307c1 5071 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5072 return 0;
5073
5074 /* Quick check: They should all have the same number of enumerals. */
54d343a2 5075 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5076 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5077 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5078 return 0;
5079
5080 /* All the sanity checks passed, so we might have a set of
5081 identical enumeration types. Perform a more complete
5082 comparison of the type of each symbol. */
54d343a2 5083 for (i = 1; i < syms.size (); i++)
d12307c1
PMR
5084 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5085 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5086 return 0;
5087
5088 return 1;
5089}
5090
54d343a2 5091/* Remove any non-debugging symbols in SYMS that definitely
96d887e8
PH
5092 duplicate other symbols in the list (The only case I know of where
5093 this happens is when object files containing stabs-in-ecoff are
5094 linked with files containing ordinary ecoff debugging symbols (or no
5095 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5096 Returns the number of items in the modified list. */
4c4b4cd2 5097
96d887e8 5098static int
54d343a2 5099remove_extra_symbols (std::vector<struct block_symbol> *syms)
96d887e8
PH
5100{
5101 int i, j;
4c4b4cd2 5102
8f17729f
JB
5103 /* We should never be called with less than 2 symbols, as there
5104 cannot be any extra symbol in that case. But it's easy to
5105 handle, since we have nothing to do in that case. */
54d343a2
TT
5106 if (syms->size () < 2)
5107 return syms->size ();
8f17729f 5108
96d887e8 5109 i = 0;
54d343a2 5110 while (i < syms->size ())
96d887e8 5111 {
a35ddb44 5112 int remove_p = 0;
339c13b6
JB
5113
5114 /* If two symbols have the same name and one of them is a stub type,
5115 the get rid of the stub. */
5116
54d343a2
TT
5117 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol))
5118 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL)
339c13b6 5119 {
54d343a2 5120 for (j = 0; j < syms->size (); j++)
339c13b6
JB
5121 {
5122 if (j != i
54d343a2
TT
5123 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol))
5124 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5125 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5126 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0)
a35ddb44 5127 remove_p = 1;
339c13b6
JB
5128 }
5129 }
5130
5131 /* Two symbols with the same name, same class and same address
5132 should be identical. */
5133
54d343a2
TT
5134 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL
5135 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC
5136 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol)))
96d887e8 5137 {
54d343a2 5138 for (j = 0; j < syms->size (); j += 1)
96d887e8
PH
5139 {
5140 if (i != j
54d343a2
TT
5141 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL
5142 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol),
5143 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0
5144 && SYMBOL_CLASS ((*syms)[i].symbol)
5145 == SYMBOL_CLASS ((*syms)[j].symbol)
5146 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol)
5147 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol))
a35ddb44 5148 remove_p = 1;
4c4b4cd2 5149 }
4c4b4cd2 5150 }
339c13b6 5151
a35ddb44 5152 if (remove_p)
54d343a2 5153 syms->erase (syms->begin () + i);
339c13b6 5154
96d887e8 5155 i += 1;
14f9c5c9 5156 }
8f17729f
JB
5157
5158 /* If all the remaining symbols are identical enumerals, then
5159 just keep the first one and discard the rest.
5160
5161 Unlike what we did previously, we do not discard any entry
5162 unless they are ALL identical. This is because the symbol
5163 comparison is not a strict comparison, but rather a practical
5164 comparison. If all symbols are considered identical, then
5165 we can just go ahead and use the first one and discard the rest.
5166 But if we cannot reduce the list to a single element, we have
5167 to ask the user to disambiguate anyways. And if we have to
5168 present a multiple-choice menu, it's less confusing if the list
5169 isn't missing some choices that were identical and yet distinct. */
54d343a2
TT
5170 if (symbols_are_identical_enums (*syms))
5171 syms->resize (1);
8f17729f 5172
54d343a2 5173 return syms->size ();
14f9c5c9
AS
5174}
5175
96d887e8
PH
5176/* Given a type that corresponds to a renaming entity, use the type name
5177 to extract the scope (package name or function name, fully qualified,
5178 and following the GNAT encoding convention) where this renaming has been
49d83361 5179 defined. */
4c4b4cd2 5180
49d83361 5181static std::string
96d887e8 5182xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5183{
96d887e8 5184 /* The renaming types adhere to the following convention:
0963b4bd 5185 <scope>__<rename>___<XR extension>.
96d887e8
PH
5186 So, to extract the scope, we search for the "___XR" extension,
5187 and then backtrack until we find the first "__". */
76a01679 5188
a737d952 5189 const char *name = TYPE_NAME (renaming_type);
108d56a4
SM
5190 const char *suffix = strstr (name, "___XR");
5191 const char *last;
14f9c5c9 5192
96d887e8
PH
5193 /* Now, backtrack a bit until we find the first "__". Start looking
5194 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5195
96d887e8
PH
5196 for (last = suffix - 3; last > name; last--)
5197 if (last[0] == '_' && last[1] == '_')
5198 break;
76a01679 5199
96d887e8 5200 /* Make a copy of scope and return it. */
49d83361 5201 return std::string (name, last);
4c4b4cd2
PH
5202}
5203
96d887e8 5204/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5205
96d887e8
PH
5206static int
5207is_package_name (const char *name)
4c4b4cd2 5208{
96d887e8
PH
5209 /* Here, We take advantage of the fact that no symbols are generated
5210 for packages, while symbols are generated for each function.
5211 So the condition for NAME represent a package becomes equivalent
5212 to NAME not existing in our list of symbols. There is only one
5213 small complication with library-level functions (see below). */
4c4b4cd2 5214
96d887e8
PH
5215 /* If it is a function that has not been defined at library level,
5216 then we should be able to look it up in the symbols. */
5217 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5218 return 0;
14f9c5c9 5219
96d887e8
PH
5220 /* Library-level function names start with "_ada_". See if function
5221 "_ada_" followed by NAME can be found. */
14f9c5c9 5222
96d887e8 5223 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5224 functions names cannot contain "__" in them. */
96d887e8
PH
5225 if (strstr (name, "__") != NULL)
5226 return 0;
4c4b4cd2 5227
528e1572 5228 std::string fun_name = string_printf ("_ada_%s", name);
14f9c5c9 5229
528e1572 5230 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL);
96d887e8 5231}
14f9c5c9 5232
96d887e8 5233/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5234 not visible from FUNCTION_NAME. */
14f9c5c9 5235
96d887e8 5236static int
0d5cff50 5237old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5238{
aeb5907d
JB
5239 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5240 return 0;
5241
49d83361 5242 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym));
14f9c5c9 5243
96d887e8 5244 /* If the rename has been defined in a package, then it is visible. */
49d83361
TT
5245 if (is_package_name (scope.c_str ()))
5246 return 0;
14f9c5c9 5247
96d887e8
PH
5248 /* Check that the rename is in the current function scope by checking
5249 that its name starts with SCOPE. */
76a01679 5250
96d887e8
PH
5251 /* If the function name starts with "_ada_", it means that it is
5252 a library-level function. Strip this prefix before doing the
5253 comparison, as the encoding for the renaming does not contain
5254 this prefix. */
61012eef 5255 if (startswith (function_name, "_ada_"))
96d887e8 5256 function_name += 5;
f26caa11 5257
49d83361 5258 return !startswith (function_name, scope.c_str ());
f26caa11
PH
5259}
5260
aeb5907d
JB
5261/* Remove entries from SYMS that corresponds to a renaming entity that
5262 is not visible from the function associated with CURRENT_BLOCK or
5263 that is superfluous due to the presence of more specific renaming
5264 information. Places surviving symbols in the initial entries of
5265 SYMS and returns the number of surviving symbols.
96d887e8
PH
5266
5267 Rationale:
aeb5907d
JB
5268 First, in cases where an object renaming is implemented as a
5269 reference variable, GNAT may produce both the actual reference
5270 variable and the renaming encoding. In this case, we discard the
5271 latter.
5272
5273 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5274 entity. Unfortunately, STABS currently does not support the definition
5275 of types that are local to a given lexical block, so all renamings types
5276 are emitted at library level. As a consequence, if an application
5277 contains two renaming entities using the same name, and a user tries to
5278 print the value of one of these entities, the result of the ada symbol
5279 lookup will also contain the wrong renaming type.
f26caa11 5280
96d887e8
PH
5281 This function partially covers for this limitation by attempting to
5282 remove from the SYMS list renaming symbols that should be visible
5283 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5284 method with the current information available. The implementation
5285 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5286
5287 - When the user tries to print a rename in a function while there
5288 is another rename entity defined in a package: Normally, the
5289 rename in the function has precedence over the rename in the
5290 package, so the latter should be removed from the list. This is
5291 currently not the case.
5292
5293 - This function will incorrectly remove valid renames if
5294 the CURRENT_BLOCK corresponds to a function which symbol name
5295 has been changed by an "Export" pragma. As a consequence,
5296 the user will be unable to print such rename entities. */
4c4b4cd2 5297
14f9c5c9 5298static int
54d343a2
TT
5299remove_irrelevant_renamings (std::vector<struct block_symbol> *syms,
5300 const struct block *current_block)
4c4b4cd2
PH
5301{
5302 struct symbol *current_function;
0d5cff50 5303 const char *current_function_name;
4c4b4cd2 5304 int i;
aeb5907d
JB
5305 int is_new_style_renaming;
5306
5307 /* If there is both a renaming foo___XR... encoded as a variable and
5308 a simple variable foo in the same block, discard the latter.
0963b4bd 5309 First, zero out such symbols, then compress. */
aeb5907d 5310 is_new_style_renaming = 0;
54d343a2 5311 for (i = 0; i < syms->size (); i += 1)
aeb5907d 5312 {
54d343a2
TT
5313 struct symbol *sym = (*syms)[i].symbol;
5314 const struct block *block = (*syms)[i].block;
aeb5907d
JB
5315 const char *name;
5316 const char *suffix;
5317
5318 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5319 continue;
5320 name = SYMBOL_LINKAGE_NAME (sym);
5321 suffix = strstr (name, "___XR");
5322
5323 if (suffix != NULL)
5324 {
5325 int name_len = suffix - name;
5326 int j;
5b4ee69b 5327
aeb5907d 5328 is_new_style_renaming = 1;
54d343a2
TT
5329 for (j = 0; j < syms->size (); j += 1)
5330 if (i != j && (*syms)[j].symbol != NULL
5331 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol),
aeb5907d 5332 name_len) == 0
54d343a2
TT
5333 && block == (*syms)[j].block)
5334 (*syms)[j].symbol = NULL;
aeb5907d
JB
5335 }
5336 }
5337 if (is_new_style_renaming)
5338 {
5339 int j, k;
5340
54d343a2
TT
5341 for (j = k = 0; j < syms->size (); j += 1)
5342 if ((*syms)[j].symbol != NULL)
aeb5907d 5343 {
54d343a2 5344 (*syms)[k] = (*syms)[j];
aeb5907d
JB
5345 k += 1;
5346 }
5347 return k;
5348 }
4c4b4cd2
PH
5349
5350 /* Extract the function name associated to CURRENT_BLOCK.
5351 Abort if unable to do so. */
76a01679 5352
4c4b4cd2 5353 if (current_block == NULL)
54d343a2 5354 return syms->size ();
76a01679 5355
7f0df278 5356 current_function = block_linkage_function (current_block);
4c4b4cd2 5357 if (current_function == NULL)
54d343a2 5358 return syms->size ();
4c4b4cd2
PH
5359
5360 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5361 if (current_function_name == NULL)
54d343a2 5362 return syms->size ();
4c4b4cd2
PH
5363
5364 /* Check each of the symbols, and remove it from the list if it is
5365 a type corresponding to a renaming that is out of the scope of
5366 the current block. */
5367
5368 i = 0;
54d343a2 5369 while (i < syms->size ())
4c4b4cd2 5370 {
54d343a2 5371 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL)
aeb5907d 5372 == ADA_OBJECT_RENAMING
54d343a2
TT
5373 && old_renaming_is_invisible ((*syms)[i].symbol,
5374 current_function_name))
5375 syms->erase (syms->begin () + i);
4c4b4cd2
PH
5376 else
5377 i += 1;
5378 }
5379
54d343a2 5380 return syms->size ();
4c4b4cd2
PH
5381}
5382
339c13b6
JB
5383/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5384 whose name and domain match NAME and DOMAIN respectively.
5385 If no match was found, then extend the search to "enclosing"
5386 routines (in other words, if we're inside a nested function,
5387 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5388 If WILD_MATCH_P is nonzero, perform the naming matching in
5389 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5390
5391 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5392
5393static void
b5ec771e
PA
5394ada_add_local_symbols (struct obstack *obstackp,
5395 const lookup_name_info &lookup_name,
5396 const struct block *block, domain_enum domain)
339c13b6
JB
5397{
5398 int block_depth = 0;
5399
5400 while (block != NULL)
5401 {
5402 block_depth += 1;
b5ec771e 5403 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
339c13b6
JB
5404
5405 /* If we found a non-function match, assume that's the one. */
5406 if (is_nonfunction (defns_collected (obstackp, 0),
5407 num_defns_collected (obstackp)))
5408 return;
5409
5410 block = BLOCK_SUPERBLOCK (block);
5411 }
5412
5413 /* If no luck so far, try to find NAME as a local symbol in some lexically
5414 enclosing subprogram. */
5415 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
b5ec771e 5416 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
339c13b6
JB
5417}
5418
ccefe4c4 5419/* An object of this type is used as the user_data argument when
40658b94 5420 calling the map_matching_symbols method. */
ccefe4c4 5421
40658b94 5422struct match_data
ccefe4c4 5423{
40658b94 5424 struct objfile *objfile;
ccefe4c4 5425 struct obstack *obstackp;
40658b94
PH
5426 struct symbol *arg_sym;
5427 int found_sym;
ccefe4c4
TT
5428};
5429
22cee43f 5430/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5431 to a list of symbols. DATA0 is a pointer to a struct match_data *
5432 containing the obstack that collects the symbol list, the file that SYM
5433 must come from, a flag indicating whether a non-argument symbol has
5434 been found in the current block, and the last argument symbol
5435 passed in SYM within the current block (if any). When SYM is null,
5436 marking the end of a block, the argument symbol is added if no
5437 other has been found. */
ccefe4c4 5438
40658b94
PH
5439static int
5440aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5441{
40658b94
PH
5442 struct match_data *data = (struct match_data *) data0;
5443
5444 if (sym == NULL)
5445 {
5446 if (!data->found_sym && data->arg_sym != NULL)
5447 add_defn_to_vec (data->obstackp,
5448 fixup_symbol_section (data->arg_sym, data->objfile),
5449 block);
5450 data->found_sym = 0;
5451 data->arg_sym = NULL;
5452 }
5453 else
5454 {
5455 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5456 return 0;
5457 else if (SYMBOL_IS_ARGUMENT (sym))
5458 data->arg_sym = sym;
5459 else
5460 {
5461 data->found_sym = 1;
5462 add_defn_to_vec (data->obstackp,
5463 fixup_symbol_section (sym, data->objfile),
5464 block);
5465 }
5466 }
5467 return 0;
5468}
5469
b5ec771e
PA
5470/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5471 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5472 symbols to OBSTACKP. Return whether we found such symbols. */
22cee43f
PMR
5473
5474static int
5475ada_add_block_renamings (struct obstack *obstackp,
5476 const struct block *block,
b5ec771e
PA
5477 const lookup_name_info &lookup_name,
5478 domain_enum domain)
22cee43f
PMR
5479{
5480 struct using_direct *renaming;
5481 int defns_mark = num_defns_collected (obstackp);
5482
b5ec771e
PA
5483 symbol_name_matcher_ftype *name_match
5484 = ada_get_symbol_name_matcher (lookup_name);
5485
22cee43f
PMR
5486 for (renaming = block_using (block);
5487 renaming != NULL;
5488 renaming = renaming->next)
5489 {
5490 const char *r_name;
22cee43f
PMR
5491
5492 /* Avoid infinite recursions: skip this renaming if we are actually
5493 already traversing it.
5494
5495 Currently, symbol lookup in Ada don't use the namespace machinery from
5496 C++/Fortran support: skip namespace imports that use them. */
5497 if (renaming->searched
5498 || (renaming->import_src != NULL
5499 && renaming->import_src[0] != '\0')
5500 || (renaming->import_dest != NULL
5501 && renaming->import_dest[0] != '\0'))
5502 continue;
5503 renaming->searched = 1;
5504
5505 /* TODO: here, we perform another name-based symbol lookup, which can
5506 pull its own multiple overloads. In theory, we should be able to do
5507 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5508 not a simple name. But in order to do this, we would need to enhance
5509 the DWARF reader to associate a symbol to this renaming, instead of a
5510 name. So, for now, we do something simpler: re-use the C++/Fortran
5511 namespace machinery. */
5512 r_name = (renaming->alias != NULL
5513 ? renaming->alias
5514 : renaming->declaration);
b5ec771e
PA
5515 if (name_match (r_name, lookup_name, NULL))
5516 {
5517 lookup_name_info decl_lookup_name (renaming->declaration,
5518 lookup_name.match_type ());
5519 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5520 1, NULL);
5521 }
22cee43f
PMR
5522 renaming->searched = 0;
5523 }
5524 return num_defns_collected (obstackp) != defns_mark;
5525}
5526
db230ce3
JB
5527/* Implements compare_names, but only applying the comparision using
5528 the given CASING. */
5b4ee69b 5529
40658b94 5530static int
db230ce3
JB
5531compare_names_with_case (const char *string1, const char *string2,
5532 enum case_sensitivity casing)
40658b94
PH
5533{
5534 while (*string1 != '\0' && *string2 != '\0')
5535 {
db230ce3
JB
5536 char c1, c2;
5537
40658b94
PH
5538 if (isspace (*string1) || isspace (*string2))
5539 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5540
5541 if (casing == case_sensitive_off)
5542 {
5543 c1 = tolower (*string1);
5544 c2 = tolower (*string2);
5545 }
5546 else
5547 {
5548 c1 = *string1;
5549 c2 = *string2;
5550 }
5551 if (c1 != c2)
40658b94 5552 break;
db230ce3 5553
40658b94
PH
5554 string1 += 1;
5555 string2 += 1;
5556 }
db230ce3 5557
40658b94
PH
5558 switch (*string1)
5559 {
5560 case '(':
5561 return strcmp_iw_ordered (string1, string2);
5562 case '_':
5563 if (*string2 == '\0')
5564 {
052874e8 5565 if (is_name_suffix (string1))
40658b94
PH
5566 return 0;
5567 else
1a1d5513 5568 return 1;
40658b94 5569 }
dbb8534f 5570 /* FALLTHROUGH */
40658b94
PH
5571 default:
5572 if (*string2 == '(')
5573 return strcmp_iw_ordered (string1, string2);
5574 else
db230ce3
JB
5575 {
5576 if (casing == case_sensitive_off)
5577 return tolower (*string1) - tolower (*string2);
5578 else
5579 return *string1 - *string2;
5580 }
40658b94 5581 }
ccefe4c4
TT
5582}
5583
db230ce3
JB
5584/* Compare STRING1 to STRING2, with results as for strcmp.
5585 Compatible with strcmp_iw_ordered in that...
5586
5587 strcmp_iw_ordered (STRING1, STRING2) <= 0
5588
5589 ... implies...
5590
5591 compare_names (STRING1, STRING2) <= 0
5592
5593 (they may differ as to what symbols compare equal). */
5594
5595static int
5596compare_names (const char *string1, const char *string2)
5597{
5598 int result;
5599
5600 /* Similar to what strcmp_iw_ordered does, we need to perform
5601 a case-insensitive comparison first, and only resort to
5602 a second, case-sensitive, comparison if the first one was
5603 not sufficient to differentiate the two strings. */
5604
5605 result = compare_names_with_case (string1, string2, case_sensitive_off);
5606 if (result == 0)
5607 result = compare_names_with_case (string1, string2, case_sensitive_on);
5608
5609 return result;
5610}
5611
b5ec771e
PA
5612/* Convenience function to get at the Ada encoded lookup name for
5613 LOOKUP_NAME, as a C string. */
5614
5615static const char *
5616ada_lookup_name (const lookup_name_info &lookup_name)
5617{
5618 return lookup_name.ada ().lookup_name ().c_str ();
5619}
5620
339c13b6 5621/* Add to OBSTACKP all non-local symbols whose name and domain match
b5ec771e
PA
5622 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5623 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5624 symbols otherwise. */
339c13b6
JB
5625
5626static void
b5ec771e
PA
5627add_nonlocal_symbols (struct obstack *obstackp,
5628 const lookup_name_info &lookup_name,
5629 domain_enum domain, int global)
339c13b6
JB
5630{
5631 struct objfile *objfile;
22cee43f 5632 struct compunit_symtab *cu;
40658b94 5633 struct match_data data;
339c13b6 5634
6475f2fe 5635 memset (&data, 0, sizeof data);
ccefe4c4 5636 data.obstackp = obstackp;
339c13b6 5637
b5ec771e
PA
5638 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5639
ccefe4c4 5640 ALL_OBJFILES (objfile)
40658b94
PH
5641 {
5642 data.objfile = objfile;
5643
5644 if (is_wild_match)
b5ec771e
PA
5645 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5646 domain, global,
4186eb54 5647 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5648 symbol_name_match_type::WILD,
5649 NULL);
40658b94 5650 else
b5ec771e
PA
5651 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5652 domain, global,
4186eb54 5653 aux_add_nonlocal_symbols, &data,
b5ec771e
PA
5654 symbol_name_match_type::FULL,
5655 compare_names);
22cee43f
PMR
5656
5657 ALL_OBJFILE_COMPUNITS (objfile, cu)
5658 {
5659 const struct block *global_block
5660 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5661
b5ec771e
PA
5662 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5663 domain))
22cee43f
PMR
5664 data.found_sym = 1;
5665 }
40658b94
PH
5666 }
5667
5668 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5669 {
b5ec771e
PA
5670 const char *name = ada_lookup_name (lookup_name);
5671 std::string name1 = std::string ("<_ada_") + name + '>';
5672
40658b94
PH
5673 ALL_OBJFILES (objfile)
5674 {
40658b94 5675 data.objfile = objfile;
b5ec771e
PA
5676 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5677 domain, global,
0963b4bd
MS
5678 aux_add_nonlocal_symbols,
5679 &data,
b5ec771e
PA
5680 symbol_name_match_type::FULL,
5681 compare_names);
40658b94
PH
5682 }
5683 }
339c13b6
JB
5684}
5685
b5ec771e
PA
5686/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5687 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5688 returning the number of matches. Add these to OBSTACKP.
4eeaa230 5689
22cee43f
PMR
5690 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5691 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5692 is the one match returned (no other matches in that or
d9680e73 5693 enclosing blocks is returned). If there are any matches in or
22cee43f 5694 surrounding BLOCK, then these alone are returned.
4eeaa230 5695
b5ec771e
PA
5696 Names prefixed with "standard__" are handled specially:
5697 "standard__" is first stripped off (by the lookup_name
5698 constructor), and only static and global symbols are searched.
14f9c5c9 5699
22cee43f
PMR
5700 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5701 to lookup global symbols. */
5702
5703static void
5704ada_add_all_symbols (struct obstack *obstackp,
5705 const struct block *block,
b5ec771e 5706 const lookup_name_info &lookup_name,
22cee43f
PMR
5707 domain_enum domain,
5708 int full_search,
5709 int *made_global_lookup_p)
14f9c5c9
AS
5710{
5711 struct symbol *sym;
14f9c5c9 5712
22cee43f
PMR
5713 if (made_global_lookup_p)
5714 *made_global_lookup_p = 0;
339c13b6
JB
5715
5716 /* Special case: If the user specifies a symbol name inside package
5717 Standard, do a non-wild matching of the symbol name without
5718 the "standard__" prefix. This was primarily introduced in order
5719 to allow the user to specifically access the standard exceptions
5720 using, for instance, Standard.Constraint_Error when Constraint_Error
5721 is ambiguous (due to the user defining its own Constraint_Error
5722 entity inside its program). */
b5ec771e
PA
5723 if (lookup_name.ada ().standard_p ())
5724 block = NULL;
4c4b4cd2 5725
339c13b6 5726 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5727
4eeaa230
DE
5728 if (block != NULL)
5729 {
5730 if (full_search)
b5ec771e 5731 ada_add_local_symbols (obstackp, lookup_name, block, domain);
4eeaa230
DE
5732 else
5733 {
5734 /* In the !full_search case we're are being called by
5735 ada_iterate_over_symbols, and we don't want to search
5736 superblocks. */
b5ec771e 5737 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
4eeaa230 5738 }
22cee43f
PMR
5739 if (num_defns_collected (obstackp) > 0 || !full_search)
5740 return;
4eeaa230 5741 }
d2e4a39e 5742
339c13b6
JB
5743 /* No non-global symbols found. Check our cache to see if we have
5744 already performed this search before. If we have, then return
5745 the same result. */
5746
b5ec771e
PA
5747 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5748 domain, &sym, &block))
4c4b4cd2
PH
5749 {
5750 if (sym != NULL)
b5ec771e 5751 add_defn_to_vec (obstackp, sym, block);
22cee43f 5752 return;
4c4b4cd2 5753 }
14f9c5c9 5754
22cee43f
PMR
5755 if (made_global_lookup_p)
5756 *made_global_lookup_p = 1;
b1eedac9 5757
339c13b6
JB
5758 /* Search symbols from all global blocks. */
5759
b5ec771e 5760 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
d2e4a39e 5761
4c4b4cd2 5762 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5763 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5764
22cee43f 5765 if (num_defns_collected (obstackp) == 0)
b5ec771e 5766 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
22cee43f
PMR
5767}
5768
b5ec771e
PA
5769/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5770 is non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5771 matches.
54d343a2
TT
5772 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5773 found and the blocks and symbol tables (if any) in which they were
5774 found.
22cee43f
PMR
5775
5776 When full_search is non-zero, any non-function/non-enumeral
5777 symbol match within the nest of blocks whose innermost member is BLOCK,
5778 is the one match returned (no other matches in that or
5779 enclosing blocks is returned). If there are any matches in or
5780 surrounding BLOCK, then these alone are returned.
5781
5782 Names prefixed with "standard__" are handled specially: "standard__"
5783 is first stripped off, and only static and global symbols are searched. */
5784
5785static int
b5ec771e
PA
5786ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5787 const struct block *block,
22cee43f 5788 domain_enum domain,
54d343a2 5789 std::vector<struct block_symbol> *results,
22cee43f
PMR
5790 int full_search)
5791{
22cee43f
PMR
5792 int syms_from_global_search;
5793 int ndefns;
ec6a20c2 5794 auto_obstack obstack;
22cee43f 5795
ec6a20c2 5796 ada_add_all_symbols (&obstack, block, lookup_name,
b5ec771e 5797 domain, full_search, &syms_from_global_search);
14f9c5c9 5798
ec6a20c2
JB
5799 ndefns = num_defns_collected (&obstack);
5800
54d343a2
TT
5801 struct block_symbol *base = defns_collected (&obstack, 1);
5802 for (int i = 0; i < ndefns; ++i)
5803 results->push_back (base[i]);
4c4b4cd2 5804
54d343a2 5805 ndefns = remove_extra_symbols (results);
4c4b4cd2 5806
b1eedac9 5807 if (ndefns == 0 && full_search && syms_from_global_search)
b5ec771e 5808 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
14f9c5c9 5809
b1eedac9 5810 if (ndefns == 1 && full_search && syms_from_global_search)
b5ec771e
PA
5811 cache_symbol (ada_lookup_name (lookup_name), domain,
5812 (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5813
54d343a2 5814 ndefns = remove_irrelevant_renamings (results, block);
ec6a20c2 5815
14f9c5c9
AS
5816 return ndefns;
5817}
5818
b5ec771e 5819/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
54d343a2
TT
5820 in global scopes, returning the number of matches, and filling *RESULTS
5821 with (SYM,BLOCK) tuples.
ec6a20c2 5822
4eeaa230
DE
5823 See ada_lookup_symbol_list_worker for further details. */
5824
5825int
b5ec771e 5826ada_lookup_symbol_list (const char *name, const struct block *block,
54d343a2
TT
5827 domain_enum domain,
5828 std::vector<struct block_symbol> *results)
4eeaa230 5829{
b5ec771e
PA
5830 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5831 lookup_name_info lookup_name (name, name_match_type);
5832
5833 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
4eeaa230
DE
5834}
5835
5836/* Implementation of the la_iterate_over_symbols method. */
5837
5838static void
14bc53a8 5839ada_iterate_over_symbols
b5ec771e
PA
5840 (const struct block *block, const lookup_name_info &name,
5841 domain_enum domain,
14bc53a8 5842 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5843{
5844 int ndefs, i;
54d343a2 5845 std::vector<struct block_symbol> results;
4eeaa230
DE
5846
5847 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
ec6a20c2 5848
4eeaa230
DE
5849 for (i = 0; i < ndefs; ++i)
5850 {
7e41c8db 5851 if (!callback (&results[i]))
4eeaa230
DE
5852 break;
5853 }
5854}
5855
4e5c77fe
JB
5856/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5857 to 1, but choosing the first symbol found if there are multiple
5858 choices.
5859
5e2336be
JB
5860 The result is stored in *INFO, which must be non-NULL.
5861 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5862
5863void
5864ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5865 domain_enum domain,
d12307c1 5866 struct block_symbol *info)
14f9c5c9 5867{
b5ec771e
PA
5868 /* Since we already have an encoded name, wrap it in '<>' to force a
5869 verbatim match. Otherwise, if the name happens to not look like
5870 an encoded name (because it doesn't include a "__"),
5871 ada_lookup_name_info would re-encode/fold it again, and that
5872 would e.g., incorrectly lowercase object renaming names like
5873 "R28b" -> "r28b". */
5874 std::string verbatim = std::string ("<") + name + '>';
5875
5e2336be 5876 gdb_assert (info != NULL);
f98fc17b 5877 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
4e5c77fe 5878}
aeb5907d
JB
5879
5880/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5881 scope and in global scopes, or NULL if none. NAME is folded and
5882 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5883 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5884 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5885
d12307c1 5886struct block_symbol
aeb5907d 5887ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5888 domain_enum domain, int *is_a_field_of_this)
aeb5907d
JB
5889{
5890 if (is_a_field_of_this != NULL)
5891 *is_a_field_of_this = 0;
5892
54d343a2 5893 std::vector<struct block_symbol> candidates;
f98fc17b 5894 int n_candidates;
f98fc17b
PA
5895
5896 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
f98fc17b
PA
5897
5898 if (n_candidates == 0)
54d343a2 5899 return {};
f98fc17b
PA
5900
5901 block_symbol info = candidates[0];
5902 info.symbol = fixup_symbol_section (info.symbol, NULL);
d12307c1 5903 return info;
4c4b4cd2 5904}
14f9c5c9 5905
d12307c1 5906static struct block_symbol
f606139a
DE
5907ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5908 const char *name,
76a01679 5909 const struct block *block,
21b556f4 5910 const domain_enum domain)
4c4b4cd2 5911{
d12307c1 5912 struct block_symbol sym;
04dccad0
JB
5913
5914 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5915 if (sym.symbol != NULL)
04dccad0
JB
5916 return sym;
5917
5918 /* If we haven't found a match at this point, try the primitive
5919 types. In other languages, this search is performed before
5920 searching for global symbols in order to short-circuit that
5921 global-symbol search if it happens that the name corresponds
5922 to a primitive type. But we cannot do the same in Ada, because
5923 it is perfectly legitimate for a program to declare a type which
5924 has the same name as a standard type. If looking up a type in
5925 that situation, we have traditionally ignored the primitive type
5926 in favor of user-defined types. This is why, unlike most other
5927 languages, we search the primitive types this late and only after
5928 having searched the global symbols without success. */
5929
5930 if (domain == VAR_DOMAIN)
5931 {
5932 struct gdbarch *gdbarch;
5933
5934 if (block == NULL)
5935 gdbarch = target_gdbarch ();
5936 else
5937 gdbarch = block_gdbarch (block);
d12307c1
PMR
5938 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5939 if (sym.symbol != NULL)
04dccad0
JB
5940 return sym;
5941 }
5942
d12307c1 5943 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5944}
5945
5946
4c4b4cd2
PH
5947/* True iff STR is a possible encoded suffix of a normal Ada name
5948 that is to be ignored for matching purposes. Suffixes of parallel
5949 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5950 are given by any of the regular expressions:
4c4b4cd2 5951
babe1480
JB
5952 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5953 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5954 TKB [subprogram suffix for task bodies]
babe1480 5955 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5956 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5957
5958 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5959 match is performed. This sequence is used to differentiate homonyms,
5960 is an optional part of a valid name suffix. */
4c4b4cd2 5961
14f9c5c9 5962static int
d2e4a39e 5963is_name_suffix (const char *str)
14f9c5c9
AS
5964{
5965 int k;
4c4b4cd2
PH
5966 const char *matching;
5967 const int len = strlen (str);
5968
babe1480
JB
5969 /* Skip optional leading __[0-9]+. */
5970
4c4b4cd2
PH
5971 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5972 {
babe1480
JB
5973 str += 3;
5974 while (isdigit (str[0]))
5975 str += 1;
4c4b4cd2 5976 }
babe1480
JB
5977
5978 /* [.$][0-9]+ */
4c4b4cd2 5979
babe1480 5980 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5981 {
babe1480 5982 matching = str + 1;
4c4b4cd2
PH
5983 while (isdigit (matching[0]))
5984 matching += 1;
5985 if (matching[0] == '\0')
5986 return 1;
5987 }
5988
5989 /* ___[0-9]+ */
babe1480 5990
4c4b4cd2
PH
5991 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5992 {
5993 matching = str + 3;
5994 while (isdigit (matching[0]))
5995 matching += 1;
5996 if (matching[0] == '\0')
5997 return 1;
5998 }
5999
9ac7f98e
JB
6000 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6001
6002 if (strcmp (str, "TKB") == 0)
6003 return 1;
6004
529cad9c
PH
6005#if 0
6006 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
6007 with a N at the end. Unfortunately, the compiler uses the same
6008 convention for other internal types it creates. So treating
529cad9c 6009 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
6010 some regressions. For instance, consider the case of an enumerated
6011 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
6012 name ends with N.
6013 Having a single character like this as a suffix carrying some
0963b4bd 6014 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
6015 to be something like "_N" instead. In the meantime, do not do
6016 the following check. */
6017 /* Protected Object Subprograms */
6018 if (len == 1 && str [0] == 'N')
6019 return 1;
6020#endif
6021
6022 /* _E[0-9]+[bs]$ */
6023 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6024 {
6025 matching = str + 3;
6026 while (isdigit (matching[0]))
6027 matching += 1;
6028 if ((matching[0] == 'b' || matching[0] == 's')
6029 && matching [1] == '\0')
6030 return 1;
6031 }
6032
4c4b4cd2
PH
6033 /* ??? We should not modify STR directly, as we are doing below. This
6034 is fine in this case, but may become problematic later if we find
6035 that this alternative did not work, and want to try matching
6036 another one from the begining of STR. Since we modified it, we
6037 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6038 if (str[0] == 'X')
6039 {
6040 str += 1;
d2e4a39e 6041 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6042 {
6043 if (str[0] != 'n' && str[0] != 'b')
6044 return 0;
6045 str += 1;
6046 }
14f9c5c9 6047 }
babe1480 6048
14f9c5c9
AS
6049 if (str[0] == '\000')
6050 return 1;
babe1480 6051
d2e4a39e 6052 if (str[0] == '_')
14f9c5c9
AS
6053 {
6054 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6055 return 0;
d2e4a39e 6056 if (str[2] == '_')
4c4b4cd2 6057 {
61ee279c
PH
6058 if (strcmp (str + 3, "JM") == 0)
6059 return 1;
6060 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6061 the LJM suffix in favor of the JM one. But we will
6062 still accept LJM as a valid suffix for a reasonable
6063 amount of time, just to allow ourselves to debug programs
6064 compiled using an older version of GNAT. */
4c4b4cd2
PH
6065 if (strcmp (str + 3, "LJM") == 0)
6066 return 1;
6067 if (str[3] != 'X')
6068 return 0;
1265e4aa
JB
6069 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6070 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6071 return 1;
6072 if (str[4] == 'R' && str[5] != 'T')
6073 return 1;
6074 return 0;
6075 }
6076 if (!isdigit (str[2]))
6077 return 0;
6078 for (k = 3; str[k] != '\0'; k += 1)
6079 if (!isdigit (str[k]) && str[k] != '_')
6080 return 0;
14f9c5c9
AS
6081 return 1;
6082 }
4c4b4cd2 6083 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6084 {
4c4b4cd2
PH
6085 for (k = 2; str[k] != '\0'; k += 1)
6086 if (!isdigit (str[k]) && str[k] != '_')
6087 return 0;
14f9c5c9
AS
6088 return 1;
6089 }
6090 return 0;
6091}
d2e4a39e 6092
aeb5907d
JB
6093/* Return non-zero if the string starting at NAME and ending before
6094 NAME_END contains no capital letters. */
529cad9c
PH
6095
6096static int
6097is_valid_name_for_wild_match (const char *name0)
6098{
6099 const char *decoded_name = ada_decode (name0);
6100 int i;
6101
5823c3ef
JB
6102 /* If the decoded name starts with an angle bracket, it means that
6103 NAME0 does not follow the GNAT encoding format. It should then
6104 not be allowed as a possible wild match. */
6105 if (decoded_name[0] == '<')
6106 return 0;
6107
529cad9c
PH
6108 for (i=0; decoded_name[i] != '\0'; i++)
6109 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6110 return 0;
6111
6112 return 1;
6113}
6114
73589123
PH
6115/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6116 that could start a simple name. Assumes that *NAMEP points into
6117 the string beginning at NAME0. */
4c4b4cd2 6118
14f9c5c9 6119static int
73589123 6120advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6121{
73589123 6122 const char *name = *namep;
5b4ee69b 6123
5823c3ef 6124 while (1)
14f9c5c9 6125 {
aa27d0b3 6126 int t0, t1;
73589123
PH
6127
6128 t0 = *name;
6129 if (t0 == '_')
6130 {
6131 t1 = name[1];
6132 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6133 {
6134 name += 1;
61012eef 6135 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6136 break;
6137 else
6138 name += 1;
6139 }
aa27d0b3
JB
6140 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6141 || name[2] == target0))
73589123
PH
6142 {
6143 name += 2;
6144 break;
6145 }
6146 else
6147 return 0;
6148 }
6149 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6150 name += 1;
6151 else
5823c3ef 6152 return 0;
73589123
PH
6153 }
6154
6155 *namep = name;
6156 return 1;
6157}
6158
b5ec771e
PA
6159/* Return true iff NAME encodes a name of the form prefix.PATN.
6160 Ignores any informational suffixes of NAME (i.e., for which
6161 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6162 simple name. */
73589123 6163
b5ec771e 6164static bool
73589123
PH
6165wild_match (const char *name, const char *patn)
6166{
22e048c9 6167 const char *p;
73589123
PH
6168 const char *name0 = name;
6169
6170 while (1)
6171 {
6172 const char *match = name;
6173
6174 if (*name == *patn)
6175 {
6176 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6177 if (*p != *name)
6178 break;
6179 if (*p == '\0' && is_name_suffix (name))
b5ec771e 6180 return match == name0 || is_valid_name_for_wild_match (name0);
73589123
PH
6181
6182 if (name[-1] == '_')
6183 name -= 1;
6184 }
6185 if (!advance_wild_match (&name, name0, *patn))
b5ec771e 6186 return false;
96d887e8 6187 }
96d887e8
PH
6188}
6189
b5ec771e
PA
6190/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6191 any trailing suffixes that encode debugging information or leading
6192 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6193 information that is ignored). */
40658b94 6194
b5ec771e 6195static bool
c4d840bd
PH
6196full_match (const char *sym_name, const char *search_name)
6197{
b5ec771e
PA
6198 size_t search_name_len = strlen (search_name);
6199
6200 if (strncmp (sym_name, search_name, search_name_len) == 0
6201 && is_name_suffix (sym_name + search_name_len))
6202 return true;
6203
6204 if (startswith (sym_name, "_ada_")
6205 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6206 && is_name_suffix (sym_name + search_name_len + 5))
6207 return true;
c4d840bd 6208
b5ec771e
PA
6209 return false;
6210}
c4d840bd 6211
b5ec771e
PA
6212/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6213 *defn_symbols, updating the list of symbols in OBSTACKP (if
6214 necessary). OBJFILE is the section containing BLOCK. */
96d887e8
PH
6215
6216static void
6217ada_add_block_symbols (struct obstack *obstackp,
b5ec771e
PA
6218 const struct block *block,
6219 const lookup_name_info &lookup_name,
6220 domain_enum domain, struct objfile *objfile)
96d887e8 6221{
8157b174 6222 struct block_iterator iter;
96d887e8
PH
6223 /* A matching argument symbol, if any. */
6224 struct symbol *arg_sym;
6225 /* Set true when we find a matching non-argument symbol. */
6226 int found_sym;
6227 struct symbol *sym;
6228
6229 arg_sym = NULL;
6230 found_sym = 0;
b5ec771e
PA
6231 for (sym = block_iter_match_first (block, lookup_name, &iter);
6232 sym != NULL;
6233 sym = block_iter_match_next (lookup_name, &iter))
96d887e8 6234 {
b5ec771e
PA
6235 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6236 SYMBOL_DOMAIN (sym), domain))
6237 {
6238 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6239 {
6240 if (SYMBOL_IS_ARGUMENT (sym))
6241 arg_sym = sym;
6242 else
6243 {
6244 found_sym = 1;
6245 add_defn_to_vec (obstackp,
6246 fixup_symbol_section (sym, objfile),
6247 block);
6248 }
6249 }
6250 }
96d887e8
PH
6251 }
6252
22cee43f
PMR
6253 /* Handle renamings. */
6254
b5ec771e 6255 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
22cee43f
PMR
6256 found_sym = 1;
6257
96d887e8
PH
6258 if (!found_sym && arg_sym != NULL)
6259 {
76a01679
JB
6260 add_defn_to_vec (obstackp,
6261 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6262 block);
96d887e8
PH
6263 }
6264
b5ec771e 6265 if (!lookup_name.ada ().wild_match_p ())
96d887e8
PH
6266 {
6267 arg_sym = NULL;
6268 found_sym = 0;
b5ec771e
PA
6269 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6270 const char *name = ada_lookup_name.c_str ();
6271 size_t name_len = ada_lookup_name.size ();
96d887e8
PH
6272
6273 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6274 {
4186eb54
KS
6275 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6276 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6277 {
6278 int cmp;
6279
6280 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6281 if (cmp == 0)
6282 {
61012eef 6283 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6284 if (cmp == 0)
6285 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6286 name_len);
6287 }
6288
6289 if (cmp == 0
6290 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6291 {
2a2d4dc3
AS
6292 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6293 {
6294 if (SYMBOL_IS_ARGUMENT (sym))
6295 arg_sym = sym;
6296 else
6297 {
6298 found_sym = 1;
6299 add_defn_to_vec (obstackp,
6300 fixup_symbol_section (sym, objfile),
6301 block);
6302 }
6303 }
76a01679
JB
6304 }
6305 }
76a01679 6306 }
96d887e8
PH
6307
6308 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6309 They aren't parameters, right? */
6310 if (!found_sym && arg_sym != NULL)
6311 {
6312 add_defn_to_vec (obstackp,
76a01679 6313 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6314 block);
96d887e8
PH
6315 }
6316 }
6317}
6318\f
41d27058
JB
6319
6320 /* Symbol Completion */
6321
b5ec771e 6322/* See symtab.h. */
41d27058 6323
b5ec771e
PA
6324bool
6325ada_lookup_name_info::matches
6326 (const char *sym_name,
6327 symbol_name_match_type match_type,
a207cff2 6328 completion_match_result *comp_match_res) const
41d27058 6329{
b5ec771e
PA
6330 bool match = false;
6331 const char *text = m_encoded_name.c_str ();
6332 size_t text_len = m_encoded_name.size ();
41d27058
JB
6333
6334 /* First, test against the fully qualified name of the symbol. */
6335
6336 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6337 match = true;
41d27058 6338
b5ec771e 6339 if (match && !m_encoded_p)
41d27058
JB
6340 {
6341 /* One needed check before declaring a positive match is to verify
6342 that iff we are doing a verbatim match, the decoded version
6343 of the symbol name starts with '<'. Otherwise, this symbol name
6344 is not a suitable completion. */
6345 const char *sym_name_copy = sym_name;
b5ec771e 6346 bool has_angle_bracket;
41d27058
JB
6347
6348 sym_name = ada_decode (sym_name);
6349 has_angle_bracket = (sym_name[0] == '<');
b5ec771e 6350 match = (has_angle_bracket == m_verbatim_p);
41d27058
JB
6351 sym_name = sym_name_copy;
6352 }
6353
b5ec771e 6354 if (match && !m_verbatim_p)
41d27058
JB
6355 {
6356 /* When doing non-verbatim match, another check that needs to
6357 be done is to verify that the potentially matching symbol name
6358 does not include capital letters, because the ada-mode would
6359 not be able to understand these symbol names without the
6360 angle bracket notation. */
6361 const char *tmp;
6362
6363 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6364 if (*tmp != '\0')
b5ec771e 6365 match = false;
41d27058
JB
6366 }
6367
6368 /* Second: Try wild matching... */
6369
b5ec771e 6370 if (!match && m_wild_match_p)
41d27058
JB
6371 {
6372 /* Since we are doing wild matching, this means that TEXT
6373 may represent an unqualified symbol name. We therefore must
6374 also compare TEXT against the unqualified name of the symbol. */
6375 sym_name = ada_unqualified_name (ada_decode (sym_name));
6376
6377 if (strncmp (sym_name, text, text_len) == 0)
b5ec771e 6378 match = true;
41d27058
JB
6379 }
6380
b5ec771e 6381 /* Finally: If we found a match, prepare the result to return. */
41d27058
JB
6382
6383 if (!match)
b5ec771e 6384 return false;
41d27058 6385
a207cff2 6386 if (comp_match_res != NULL)
b5ec771e 6387 {
a207cff2 6388 std::string &match_str = comp_match_res->match.storage ();
41d27058 6389
b5ec771e 6390 if (!m_encoded_p)
a207cff2 6391 match_str = ada_decode (sym_name);
b5ec771e
PA
6392 else
6393 {
6394 if (m_verbatim_p)
6395 match_str = add_angle_brackets (sym_name);
6396 else
6397 match_str = sym_name;
41d27058 6398
b5ec771e 6399 }
a207cff2
PA
6400
6401 comp_match_res->set_match (match_str.c_str ());
41d27058
JB
6402 }
6403
b5ec771e 6404 return true;
41d27058
JB
6405}
6406
b5ec771e 6407/* Add the list of possible symbol names completing TEXT to TRACKER.
eb3ff9a5 6408 WORD is the entire command on which completion is made. */
41d27058 6409
eb3ff9a5
PA
6410static void
6411ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6412 complete_symbol_mode mode,
b5ec771e
PA
6413 symbol_name_match_type name_match_type,
6414 const char *text, const char *word,
eb3ff9a5 6415 enum type_code code)
41d27058 6416{
41d27058 6417 struct symbol *sym;
43f3e411 6418 struct compunit_symtab *s;
41d27058
JB
6419 struct minimal_symbol *msymbol;
6420 struct objfile *objfile;
3977b71f 6421 const struct block *b, *surrounding_static_block = 0;
8157b174 6422 struct block_iterator iter;
41d27058 6423
2f68a895
TT
6424 gdb_assert (code == TYPE_CODE_UNDEF);
6425
1b026119 6426 lookup_name_info lookup_name (text, name_match_type, true);
41d27058
JB
6427
6428 /* First, look at the partial symtab symbols. */
14bc53a8 6429 expand_symtabs_matching (NULL,
b5ec771e
PA
6430 lookup_name,
6431 NULL,
14bc53a8
PA
6432 NULL,
6433 ALL_DOMAIN);
41d27058
JB
6434
6435 /* At this point scan through the misc symbol vectors and add each
6436 symbol you find to the list. Eventually we want to ignore
6437 anything that isn't a text symbol (everything else will be
6438 handled by the psymtab code above). */
6439
6440 ALL_MSYMBOLS (objfile, msymbol)
6441 {
6442 QUIT;
b5ec771e 6443
f9d67a22
PA
6444 if (completion_skip_symbol (mode, msymbol))
6445 continue;
6446
d4c2a405
PA
6447 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6448
6449 /* Ada minimal symbols won't have their language set to Ada. If
6450 we let completion_list_add_name compare using the
6451 default/C-like matcher, then when completing e.g., symbols in a
6452 package named "pck", we'd match internal Ada symbols like
6453 "pckS", which are invalid in an Ada expression, unless you wrap
6454 them in '<' '>' to request a verbatim match.
6455
6456 Unfortunately, some Ada encoded names successfully demangle as
6457 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6458 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6459 with the wrong language set. Paper over that issue here. */
6460 if (symbol_language == language_auto
6461 || symbol_language == language_cplus)
6462 symbol_language = language_ada;
6463
b5ec771e 6464 completion_list_add_name (tracker,
d4c2a405 6465 symbol_language,
b5ec771e 6466 MSYMBOL_LINKAGE_NAME (msymbol),
1b026119 6467 lookup_name, text, word);
41d27058
JB
6468 }
6469
6470 /* Search upwards from currently selected frame (so that we can
6471 complete on local vars. */
6472
6473 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6474 {
6475 if (!BLOCK_SUPERBLOCK (b))
6476 surrounding_static_block = b; /* For elmin of dups */
6477
6478 ALL_BLOCK_SYMBOLS (b, iter, sym)
6479 {
f9d67a22
PA
6480 if (completion_skip_symbol (mode, sym))
6481 continue;
6482
b5ec771e
PA
6483 completion_list_add_name (tracker,
6484 SYMBOL_LANGUAGE (sym),
6485 SYMBOL_LINKAGE_NAME (sym),
1b026119 6486 lookup_name, text, word);
41d27058
JB
6487 }
6488 }
6489
6490 /* Go through the symtabs and check the externs and statics for
43f3e411 6491 symbols which match. */
41d27058 6492
43f3e411 6493 ALL_COMPUNITS (objfile, s)
41d27058
JB
6494 {
6495 QUIT;
43f3e411 6496 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6497 ALL_BLOCK_SYMBOLS (b, iter, sym)
6498 {
f9d67a22
PA
6499 if (completion_skip_symbol (mode, sym))
6500 continue;
6501
b5ec771e
PA
6502 completion_list_add_name (tracker,
6503 SYMBOL_LANGUAGE (sym),
6504 SYMBOL_LINKAGE_NAME (sym),
1b026119 6505 lookup_name, text, word);
41d27058
JB
6506 }
6507 }
6508
43f3e411 6509 ALL_COMPUNITS (objfile, s)
41d27058
JB
6510 {
6511 QUIT;
43f3e411 6512 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6513 /* Don't do this block twice. */
6514 if (b == surrounding_static_block)
6515 continue;
6516 ALL_BLOCK_SYMBOLS (b, iter, sym)
6517 {
f9d67a22
PA
6518 if (completion_skip_symbol (mode, sym))
6519 continue;
6520
b5ec771e
PA
6521 completion_list_add_name (tracker,
6522 SYMBOL_LANGUAGE (sym),
6523 SYMBOL_LINKAGE_NAME (sym),
1b026119 6524 lookup_name, text, word);
41d27058
JB
6525 }
6526 }
41d27058
JB
6527}
6528
963a6417 6529 /* Field Access */
96d887e8 6530
73fb9985
JB
6531/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6532 for tagged types. */
6533
6534static int
6535ada_is_dispatch_table_ptr_type (struct type *type)
6536{
0d5cff50 6537 const char *name;
73fb9985
JB
6538
6539 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6540 return 0;
6541
6542 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6543 if (name == NULL)
6544 return 0;
6545
6546 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6547}
6548
ac4a2da4
JG
6549/* Return non-zero if TYPE is an interface tag. */
6550
6551static int
6552ada_is_interface_tag (struct type *type)
6553{
6554 const char *name = TYPE_NAME (type);
6555
6556 if (name == NULL)
6557 return 0;
6558
6559 return (strcmp (name, "ada__tags__interface_tag") == 0);
6560}
6561
963a6417
PH
6562/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6563 to be invisible to users. */
96d887e8 6564
963a6417
PH
6565int
6566ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6567{
963a6417
PH
6568 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6569 return 1;
ffde82bf 6570
73fb9985
JB
6571 /* Check the name of that field. */
6572 {
6573 const char *name = TYPE_FIELD_NAME (type, field_num);
6574
6575 /* Anonymous field names should not be printed.
6576 brobecker/2007-02-20: I don't think this can actually happen
6577 but we don't want to print the value of annonymous fields anyway. */
6578 if (name == NULL)
6579 return 1;
6580
ffde82bf
JB
6581 /* Normally, fields whose name start with an underscore ("_")
6582 are fields that have been internally generated by the compiler,
6583 and thus should not be printed. The "_parent" field is special,
6584 however: This is a field internally generated by the compiler
6585 for tagged types, and it contains the components inherited from
6586 the parent type. This field should not be printed as is, but
6587 should not be ignored either. */
61012eef 6588 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6589 return 1;
6590 }
6591
ac4a2da4
JG
6592 /* If this is the dispatch table of a tagged type or an interface tag,
6593 then ignore. */
73fb9985 6594 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6595 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6596 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6597 return 1;
6598
6599 /* Not a special field, so it should not be ignored. */
6600 return 0;
963a6417 6601}
96d887e8 6602
963a6417 6603/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6604 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6605
963a6417
PH
6606int
6607ada_is_tagged_type (struct type *type, int refok)
6608{
988f6b3d 6609 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6610}
96d887e8 6611
963a6417 6612/* True iff TYPE represents the type of X'Tag */
96d887e8 6613
963a6417
PH
6614int
6615ada_is_tag_type (struct type *type)
6616{
460efde1
JB
6617 type = ada_check_typedef (type);
6618
963a6417
PH
6619 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6620 return 0;
6621 else
96d887e8 6622 {
963a6417 6623 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6624
963a6417
PH
6625 return (name != NULL
6626 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6627 }
96d887e8
PH
6628}
6629
963a6417 6630/* The type of the tag on VAL. */
76a01679 6631
963a6417
PH
6632struct type *
6633ada_tag_type (struct value *val)
96d887e8 6634{
988f6b3d 6635 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6636}
96d887e8 6637
b50d69b5
JG
6638/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6639 retired at Ada 05). */
6640
6641static int
6642is_ada95_tag (struct value *tag)
6643{
6644 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6645}
6646
963a6417 6647/* The value of the tag on VAL. */
96d887e8 6648
963a6417
PH
6649struct value *
6650ada_value_tag (struct value *val)
6651{
03ee6b2e 6652 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6653}
6654
963a6417
PH
6655/* The value of the tag on the object of type TYPE whose contents are
6656 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6657 ADDRESS. */
96d887e8 6658
963a6417 6659static struct value *
10a2c479 6660value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6661 const gdb_byte *valaddr,
963a6417 6662 CORE_ADDR address)
96d887e8 6663{
b5385fc0 6664 int tag_byte_offset;
963a6417 6665 struct type *tag_type;
5b4ee69b 6666
963a6417 6667 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6668 NULL, NULL, NULL))
96d887e8 6669 {
fc1a4b47 6670 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6671 ? NULL
6672 : valaddr + tag_byte_offset);
963a6417 6673 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6674
963a6417 6675 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6676 }
963a6417
PH
6677 return NULL;
6678}
96d887e8 6679
963a6417
PH
6680static struct type *
6681type_from_tag (struct value *tag)
6682{
6683 const char *type_name = ada_tag_name (tag);
5b4ee69b 6684
963a6417
PH
6685 if (type_name != NULL)
6686 return ada_find_any_type (ada_encode (type_name));
6687 return NULL;
6688}
96d887e8 6689
b50d69b5
JG
6690/* Given a value OBJ of a tagged type, return a value of this
6691 type at the base address of the object. The base address, as
6692 defined in Ada.Tags, it is the address of the primary tag of
6693 the object, and therefore where the field values of its full
6694 view can be fetched. */
6695
6696struct value *
6697ada_tag_value_at_base_address (struct value *obj)
6698{
b50d69b5
JG
6699 struct value *val;
6700 LONGEST offset_to_top = 0;
6701 struct type *ptr_type, *obj_type;
6702 struct value *tag;
6703 CORE_ADDR base_address;
6704
6705 obj_type = value_type (obj);
6706
6707 /* It is the responsability of the caller to deref pointers. */
6708
6709 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6710 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6711 return obj;
6712
6713 tag = ada_value_tag (obj);
6714 if (!tag)
6715 return obj;
6716
6717 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6718
6719 if (is_ada95_tag (tag))
6720 return obj;
6721
08f49010
XR
6722 ptr_type = language_lookup_primitive_type
6723 (language_def (language_ada), target_gdbarch(), "storage_offset");
b50d69b5
JG
6724 ptr_type = lookup_pointer_type (ptr_type);
6725 val = value_cast (ptr_type, tag);
6726 if (!val)
6727 return obj;
6728
6729 /* It is perfectly possible that an exception be raised while
6730 trying to determine the base address, just like for the tag;
6731 see ada_tag_name for more details. We do not print the error
6732 message for the same reason. */
6733
492d29ea 6734 TRY
b50d69b5
JG
6735 {
6736 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6737 }
6738
492d29ea
PA
6739 CATCH (e, RETURN_MASK_ERROR)
6740 {
6741 return obj;
6742 }
6743 END_CATCH
b50d69b5
JG
6744
6745 /* If offset is null, nothing to do. */
6746
6747 if (offset_to_top == 0)
6748 return obj;
6749
6750 /* -1 is a special case in Ada.Tags; however, what should be done
6751 is not quite clear from the documentation. So do nothing for
6752 now. */
6753
6754 if (offset_to_top == -1)
6755 return obj;
6756
08f49010
XR
6757 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6758 from the base address. This was however incompatible with
6759 C++ dispatch table: C++ uses a *negative* value to *add*
6760 to the base address. Ada's convention has therefore been
6761 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6762 use the same convention. Here, we support both cases by
6763 checking the sign of OFFSET_TO_TOP. */
6764
6765 if (offset_to_top > 0)
6766 offset_to_top = -offset_to_top;
6767
6768 base_address = value_address (obj) + offset_to_top;
b50d69b5
JG
6769 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6770
6771 /* Make sure that we have a proper tag at the new address.
6772 Otherwise, offset_to_top is bogus (which can happen when
6773 the object is not initialized yet). */
6774
6775 if (!tag)
6776 return obj;
6777
6778 obj_type = type_from_tag (tag);
6779
6780 if (!obj_type)
6781 return obj;
6782
6783 return value_from_contents_and_address (obj_type, NULL, base_address);
6784}
6785
1b611343
JB
6786/* Return the "ada__tags__type_specific_data" type. */
6787
6788static struct type *
6789ada_get_tsd_type (struct inferior *inf)
963a6417 6790{
1b611343 6791 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6792
1b611343
JB
6793 if (data->tsd_type == 0)
6794 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6795 return data->tsd_type;
6796}
529cad9c 6797
1b611343
JB
6798/* Return the TSD (type-specific data) associated to the given TAG.
6799 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6800
1b611343 6801 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6802
1b611343
JB
6803static struct value *
6804ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6805{
4c4b4cd2 6806 struct value *val;
1b611343 6807 struct type *type;
5b4ee69b 6808
1b611343
JB
6809 /* First option: The TSD is simply stored as a field of our TAG.
6810 Only older versions of GNAT would use this format, but we have
6811 to test it first, because there are no visible markers for
6812 the current approach except the absence of that field. */
529cad9c 6813
1b611343
JB
6814 val = ada_value_struct_elt (tag, "tsd", 1);
6815 if (val)
6816 return val;
e802dbe0 6817
1b611343
JB
6818 /* Try the second representation for the dispatch table (in which
6819 there is no explicit 'tsd' field in the referent of the tag pointer,
6820 and instead the tsd pointer is stored just before the dispatch
6821 table. */
e802dbe0 6822
1b611343
JB
6823 type = ada_get_tsd_type (current_inferior());
6824 if (type == NULL)
6825 return NULL;
6826 type = lookup_pointer_type (lookup_pointer_type (type));
6827 val = value_cast (type, tag);
6828 if (val == NULL)
6829 return NULL;
6830 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6831}
6832
1b611343
JB
6833/* Given the TSD of a tag (type-specific data), return a string
6834 containing the name of the associated type.
6835
6836 The returned value is good until the next call. May return NULL
6837 if we are unable to determine the tag name. */
6838
6839static char *
6840ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6841{
529cad9c
PH
6842 static char name[1024];
6843 char *p;
1b611343 6844 struct value *val;
529cad9c 6845
1b611343 6846 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6847 if (val == NULL)
1b611343 6848 return NULL;
4c4b4cd2
PH
6849 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6850 for (p = name; *p != '\0'; p += 1)
6851 if (isalpha (*p))
6852 *p = tolower (*p);
1b611343 6853 return name;
4c4b4cd2
PH
6854}
6855
6856/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6857 a C string.
6858
6859 Return NULL if the TAG is not an Ada tag, or if we were unable to
6860 determine the name of that tag. The result is good until the next
6861 call. */
4c4b4cd2
PH
6862
6863const char *
6864ada_tag_name (struct value *tag)
6865{
1b611343 6866 char *name = NULL;
5b4ee69b 6867
df407dfe 6868 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6869 return NULL;
1b611343
JB
6870
6871 /* It is perfectly possible that an exception be raised while trying
6872 to determine the TAG's name, even under normal circumstances:
6873 The associated variable may be uninitialized or corrupted, for
6874 instance. We do not let any exception propagate past this point.
6875 instead we return NULL.
6876
6877 We also do not print the error message either (which often is very
6878 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6879 the caller print a more meaningful message if necessary. */
492d29ea 6880 TRY
1b611343
JB
6881 {
6882 struct value *tsd = ada_get_tsd_from_tag (tag);
6883
6884 if (tsd != NULL)
6885 name = ada_tag_name_from_tsd (tsd);
6886 }
492d29ea
PA
6887 CATCH (e, RETURN_MASK_ERROR)
6888 {
6889 }
6890 END_CATCH
1b611343
JB
6891
6892 return name;
4c4b4cd2
PH
6893}
6894
6895/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6896
d2e4a39e 6897struct type *
ebf56fd3 6898ada_parent_type (struct type *type)
14f9c5c9
AS
6899{
6900 int i;
6901
61ee279c 6902 type = ada_check_typedef (type);
14f9c5c9
AS
6903
6904 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6905 return NULL;
6906
6907 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6908 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6909 {
6910 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6911
6912 /* If the _parent field is a pointer, then dereference it. */
6913 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6914 parent_type = TYPE_TARGET_TYPE (parent_type);
6915 /* If there is a parallel XVS type, get the actual base type. */
6916 parent_type = ada_get_base_type (parent_type);
6917
6918 return ada_check_typedef (parent_type);
6919 }
14f9c5c9
AS
6920
6921 return NULL;
6922}
6923
4c4b4cd2
PH
6924/* True iff field number FIELD_NUM of structure type TYPE contains the
6925 parent-type (inherited) fields of a derived type. Assumes TYPE is
6926 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6927
6928int
ebf56fd3 6929ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6930{
61ee279c 6931 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6932
4c4b4cd2 6933 return (name != NULL
61012eef
GB
6934 && (startswith (name, "PARENT")
6935 || startswith (name, "_parent")));
14f9c5c9
AS
6936}
6937
4c4b4cd2 6938/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6939 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6940 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6941 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6942 structures. */
14f9c5c9
AS
6943
6944int
ebf56fd3 6945ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6946{
d2e4a39e 6947 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6948
dddc0e16
JB
6949 if (name != NULL && strcmp (name, "RETVAL") == 0)
6950 {
6951 /* This happens in functions with "out" or "in out" parameters
6952 which are passed by copy. For such functions, GNAT describes
6953 the function's return type as being a struct where the return
6954 value is in a field called RETVAL, and where the other "out"
6955 or "in out" parameters are fields of that struct. This is not
6956 a wrapper. */
6957 return 0;
6958 }
6959
d2e4a39e 6960 return (name != NULL
61012eef 6961 && (startswith (name, "PARENT")
4c4b4cd2 6962 || strcmp (name, "REP") == 0
61012eef 6963 || startswith (name, "_parent")
4c4b4cd2 6964 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6965}
6966
4c4b4cd2
PH
6967/* True iff field number FIELD_NUM of structure or union type TYPE
6968 is a variant wrapper. Assumes TYPE is a structure type with at least
6969 FIELD_NUM+1 fields. */
14f9c5c9
AS
6970
6971int
ebf56fd3 6972ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6973{
d2e4a39e 6974 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6975
14f9c5c9 6976 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6977 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6978 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6979 == TYPE_CODE_UNION)));
14f9c5c9
AS
6980}
6981
6982/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6983 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6984 returns the type of the controlling discriminant for the variant.
6985 May return NULL if the type could not be found. */
14f9c5c9 6986
d2e4a39e 6987struct type *
ebf56fd3 6988ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6989{
a121b7c1 6990 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6991
988f6b3d 6992 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
6993}
6994
4c4b4cd2 6995/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6996 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6997 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6998
6999int
ebf56fd3 7000ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 7001{
d2e4a39e 7002 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 7003
14f9c5c9
AS
7004 return (name != NULL && name[0] == 'O');
7005}
7006
7007/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
7008 returns the name of the discriminant controlling the variant.
7009 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 7010
a121b7c1 7011const char *
ebf56fd3 7012ada_variant_discrim_name (struct type *type0)
14f9c5c9 7013{
d2e4a39e 7014 static char *result = NULL;
14f9c5c9 7015 static size_t result_len = 0;
d2e4a39e
AS
7016 struct type *type;
7017 const char *name;
7018 const char *discrim_end;
7019 const char *discrim_start;
14f9c5c9
AS
7020
7021 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7022 type = TYPE_TARGET_TYPE (type0);
7023 else
7024 type = type0;
7025
7026 name = ada_type_name (type);
7027
7028 if (name == NULL || name[0] == '\000')
7029 return "";
7030
7031 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7032 discrim_end -= 1)
7033 {
61012eef 7034 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7035 break;
14f9c5c9
AS
7036 }
7037 if (discrim_end == name)
7038 return "";
7039
d2e4a39e 7040 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7041 discrim_start -= 1)
7042 {
d2e4a39e 7043 if (discrim_start == name + 1)
4c4b4cd2 7044 return "";
76a01679 7045 if ((discrim_start > name + 3
61012eef 7046 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7047 || discrim_start[-1] == '.')
7048 break;
14f9c5c9
AS
7049 }
7050
7051 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7052 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7053 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7054 return result;
7055}
7056
4c4b4cd2
PH
7057/* Scan STR for a subtype-encoded number, beginning at position K.
7058 Put the position of the character just past the number scanned in
7059 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7060 Return 1 if there was a valid number at the given position, and 0
7061 otherwise. A "subtype-encoded" number consists of the absolute value
7062 in decimal, followed by the letter 'm' to indicate a negative number.
7063 Assumes 0m does not occur. */
14f9c5c9
AS
7064
7065int
d2e4a39e 7066ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7067{
7068 ULONGEST RU;
7069
d2e4a39e 7070 if (!isdigit (str[k]))
14f9c5c9
AS
7071 return 0;
7072
4c4b4cd2 7073 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7074 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7075 LONGEST. */
14f9c5c9
AS
7076 RU = 0;
7077 while (isdigit (str[k]))
7078 {
d2e4a39e 7079 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7080 k += 1;
7081 }
7082
d2e4a39e 7083 if (str[k] == 'm')
14f9c5c9
AS
7084 {
7085 if (R != NULL)
4c4b4cd2 7086 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7087 k += 1;
7088 }
7089 else if (R != NULL)
7090 *R = (LONGEST) RU;
7091
4c4b4cd2 7092 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7093 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7094 number representable as a LONGEST (although either would probably work
7095 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7096 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7097
7098 if (new_k != NULL)
7099 *new_k = k;
7100 return 1;
7101}
7102
4c4b4cd2
PH
7103/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7104 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7105 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7106
d2e4a39e 7107int
ebf56fd3 7108ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7109{
d2e4a39e 7110 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7111 int p;
7112
7113 p = 0;
7114 while (1)
7115 {
d2e4a39e 7116 switch (name[p])
4c4b4cd2
PH
7117 {
7118 case '\0':
7119 return 0;
7120 case 'S':
7121 {
7122 LONGEST W;
5b4ee69b 7123
4c4b4cd2
PH
7124 if (!ada_scan_number (name, p + 1, &W, &p))
7125 return 0;
7126 if (val == W)
7127 return 1;
7128 break;
7129 }
7130 case 'R':
7131 {
7132 LONGEST L, U;
5b4ee69b 7133
4c4b4cd2
PH
7134 if (!ada_scan_number (name, p + 1, &L, &p)
7135 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7136 return 0;
7137 if (val >= L && val <= U)
7138 return 1;
7139 break;
7140 }
7141 case 'O':
7142 return 1;
7143 default:
7144 return 0;
7145 }
7146 }
7147}
7148
0963b4bd 7149/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7150
7151/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7152 ARG_TYPE, extract and return the value of one of its (non-static)
7153 fields. FIELDNO says which field. Differs from value_primitive_field
7154 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7155
4c4b4cd2 7156static struct value *
d2e4a39e 7157ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7158 struct type *arg_type)
14f9c5c9 7159{
14f9c5c9
AS
7160 struct type *type;
7161
61ee279c 7162 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7163 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7164
4c4b4cd2 7165 /* Handle packed fields. */
14f9c5c9
AS
7166
7167 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7168 {
7169 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7170 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7171
0fd88904 7172 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7173 offset + bit_pos / 8,
7174 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7175 }
7176 else
7177 return value_primitive_field (arg1, offset, fieldno, arg_type);
7178}
7179
52ce6436
PH
7180/* Find field with name NAME in object of type TYPE. If found,
7181 set the following for each argument that is non-null:
7182 - *FIELD_TYPE_P to the field's type;
7183 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7184 an object of that type;
7185 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7186 - *BIT_SIZE_P to its size in bits if the field is packed, and
7187 0 otherwise;
7188 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7189 fields up to but not including the desired field, or by the total
7190 number of fields if not found. A NULL value of NAME never
7191 matches; the function just counts visible fields in this case.
7192
828d5846
XR
7193 Notice that we need to handle when a tagged record hierarchy
7194 has some components with the same name, like in this scenario:
7195
7196 type Top_T is tagged record
7197 N : Integer := 1;
7198 U : Integer := 974;
7199 A : Integer := 48;
7200 end record;
7201
7202 type Middle_T is new Top.Top_T with record
7203 N : Character := 'a';
7204 C : Integer := 3;
7205 end record;
7206
7207 type Bottom_T is new Middle.Middle_T with record
7208 N : Float := 4.0;
7209 C : Character := '5';
7210 X : Integer := 6;
7211 A : Character := 'J';
7212 end record;
7213
7214 Let's say we now have a variable declared and initialized as follow:
7215
7216 TC : Top_A := new Bottom_T;
7217
7218 And then we use this variable to call this function
7219
7220 procedure Assign (Obj: in out Top_T; TV : Integer);
7221
7222 as follow:
7223
7224 Assign (Top_T (B), 12);
7225
7226 Now, we're in the debugger, and we're inside that procedure
7227 then and we want to print the value of obj.c:
7228
7229 Usually, the tagged record or one of the parent type owns the
7230 component to print and there's no issue but in this particular
7231 case, what does it mean to ask for Obj.C? Since the actual
7232 type for object is type Bottom_T, it could mean two things: type
7233 component C from the Middle_T view, but also component C from
7234 Bottom_T. So in that "undefined" case, when the component is
7235 not found in the non-resolved type (which includes all the
7236 components of the parent type), then resolve it and see if we
7237 get better luck once expanded.
7238
7239 In the case of homonyms in the derived tagged type, we don't
7240 guaranty anything, and pick the one that's easiest for us
7241 to program.
7242
0963b4bd 7243 Returns 1 if found, 0 otherwise. */
52ce6436 7244
4c4b4cd2 7245static int
0d5cff50 7246find_struct_field (const char *name, struct type *type, int offset,
76a01679 7247 struct type **field_type_p,
52ce6436
PH
7248 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7249 int *index_p)
4c4b4cd2
PH
7250{
7251 int i;
828d5846 7252 int parent_offset = -1;
4c4b4cd2 7253
61ee279c 7254 type = ada_check_typedef (type);
76a01679 7255
52ce6436
PH
7256 if (field_type_p != NULL)
7257 *field_type_p = NULL;
7258 if (byte_offset_p != NULL)
d5d6fca5 7259 *byte_offset_p = 0;
52ce6436
PH
7260 if (bit_offset_p != NULL)
7261 *bit_offset_p = 0;
7262 if (bit_size_p != NULL)
7263 *bit_size_p = 0;
7264
7265 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7266 {
7267 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7268 int fld_offset = offset + bit_pos / 8;
0d5cff50 7269 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7270
4c4b4cd2
PH
7271 if (t_field_name == NULL)
7272 continue;
7273
828d5846
XR
7274 else if (ada_is_parent_field (type, i))
7275 {
7276 /* This is a field pointing us to the parent type of a tagged
7277 type. As hinted in this function's documentation, we give
7278 preference to fields in the current record first, so what
7279 we do here is just record the index of this field before
7280 we skip it. If it turns out we couldn't find our field
7281 in the current record, then we'll get back to it and search
7282 inside it whether the field might exist in the parent. */
7283
7284 parent_offset = i;
7285 continue;
7286 }
7287
52ce6436 7288 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7289 {
7290 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7291
52ce6436
PH
7292 if (field_type_p != NULL)
7293 *field_type_p = TYPE_FIELD_TYPE (type, i);
7294 if (byte_offset_p != NULL)
7295 *byte_offset_p = fld_offset;
7296 if (bit_offset_p != NULL)
7297 *bit_offset_p = bit_pos % 8;
7298 if (bit_size_p != NULL)
7299 *bit_size_p = bit_size;
76a01679
JB
7300 return 1;
7301 }
4c4b4cd2
PH
7302 else if (ada_is_wrapper_field (type, i))
7303 {
52ce6436
PH
7304 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7305 field_type_p, byte_offset_p, bit_offset_p,
7306 bit_size_p, index_p))
76a01679
JB
7307 return 1;
7308 }
4c4b4cd2
PH
7309 else if (ada_is_variant_part (type, i))
7310 {
52ce6436
PH
7311 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7312 fixed type?? */
4c4b4cd2 7313 int j;
52ce6436
PH
7314 struct type *field_type
7315 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7316
52ce6436 7317 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7318 {
76a01679
JB
7319 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7320 fld_offset
7321 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7322 field_type_p, byte_offset_p,
52ce6436 7323 bit_offset_p, bit_size_p, index_p))
76a01679 7324 return 1;
4c4b4cd2
PH
7325 }
7326 }
52ce6436
PH
7327 else if (index_p != NULL)
7328 *index_p += 1;
4c4b4cd2 7329 }
828d5846
XR
7330
7331 /* Field not found so far. If this is a tagged type which
7332 has a parent, try finding that field in the parent now. */
7333
7334 if (parent_offset != -1)
7335 {
7336 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7337 int fld_offset = offset + bit_pos / 8;
7338
7339 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7340 fld_offset, field_type_p, byte_offset_p,
7341 bit_offset_p, bit_size_p, index_p))
7342 return 1;
7343 }
7344
4c4b4cd2
PH
7345 return 0;
7346}
7347
0963b4bd 7348/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7349
52ce6436
PH
7350static int
7351num_visible_fields (struct type *type)
7352{
7353 int n;
5b4ee69b 7354
52ce6436
PH
7355 n = 0;
7356 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7357 return n;
7358}
14f9c5c9 7359
4c4b4cd2 7360/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7361 and search in it assuming it has (class) type TYPE.
7362 If found, return value, else return NULL.
7363
828d5846
XR
7364 Searches recursively through wrapper fields (e.g., '_parent').
7365
7366 In the case of homonyms in the tagged types, please refer to the
7367 long explanation in find_struct_field's function documentation. */
14f9c5c9 7368
4c4b4cd2 7369static struct value *
108d56a4 7370ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7371 struct type *type)
14f9c5c9
AS
7372{
7373 int i;
828d5846 7374 int parent_offset = -1;
14f9c5c9 7375
5b4ee69b 7376 type = ada_check_typedef (type);
52ce6436 7377 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7378 {
0d5cff50 7379 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7380
7381 if (t_field_name == NULL)
4c4b4cd2 7382 continue;
14f9c5c9 7383
828d5846
XR
7384 else if (ada_is_parent_field (type, i))
7385 {
7386 /* This is a field pointing us to the parent type of a tagged
7387 type. As hinted in this function's documentation, we give
7388 preference to fields in the current record first, so what
7389 we do here is just record the index of this field before
7390 we skip it. If it turns out we couldn't find our field
7391 in the current record, then we'll get back to it and search
7392 inside it whether the field might exist in the parent. */
7393
7394 parent_offset = i;
7395 continue;
7396 }
7397
14f9c5c9 7398 else if (field_name_match (t_field_name, name))
4c4b4cd2 7399 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7400
7401 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7402 {
0963b4bd 7403 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7404 ada_search_struct_field (name, arg,
7405 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7406 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7407
4c4b4cd2
PH
7408 if (v != NULL)
7409 return v;
7410 }
14f9c5c9
AS
7411
7412 else if (ada_is_variant_part (type, i))
4c4b4cd2 7413 {
0963b4bd 7414 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7415 int j;
5b4ee69b
MS
7416 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7417 i));
4c4b4cd2
PH
7418 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7419
52ce6436 7420 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7421 {
0963b4bd
MS
7422 struct value *v = ada_search_struct_field /* Force line
7423 break. */
06d5cf63
JB
7424 (name, arg,
7425 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7426 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7427
4c4b4cd2
PH
7428 if (v != NULL)
7429 return v;
7430 }
7431 }
14f9c5c9 7432 }
828d5846
XR
7433
7434 /* Field not found so far. If this is a tagged type which
7435 has a parent, try finding that field in the parent now. */
7436
7437 if (parent_offset != -1)
7438 {
7439 struct value *v = ada_search_struct_field (
7440 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7441 TYPE_FIELD_TYPE (type, parent_offset));
7442
7443 if (v != NULL)
7444 return v;
7445 }
7446
14f9c5c9
AS
7447 return NULL;
7448}
d2e4a39e 7449
52ce6436
PH
7450static struct value *ada_index_struct_field_1 (int *, struct value *,
7451 int, struct type *);
7452
7453
7454/* Return field #INDEX in ARG, where the index is that returned by
7455 * find_struct_field through its INDEX_P argument. Adjust the address
7456 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7457 * If found, return value, else return NULL. */
52ce6436
PH
7458
7459static struct value *
7460ada_index_struct_field (int index, struct value *arg, int offset,
7461 struct type *type)
7462{
7463 return ada_index_struct_field_1 (&index, arg, offset, type);
7464}
7465
7466
7467/* Auxiliary function for ada_index_struct_field. Like
7468 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7469 * *INDEX_P. */
52ce6436
PH
7470
7471static struct value *
7472ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7473 struct type *type)
7474{
7475 int i;
7476 type = ada_check_typedef (type);
7477
7478 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7479 {
7480 if (TYPE_FIELD_NAME (type, i) == NULL)
7481 continue;
7482 else if (ada_is_wrapper_field (type, i))
7483 {
0963b4bd 7484 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7485 ada_index_struct_field_1 (index_p, arg,
7486 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7487 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7488
52ce6436
PH
7489 if (v != NULL)
7490 return v;
7491 }
7492
7493 else if (ada_is_variant_part (type, i))
7494 {
7495 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7496 find_struct_field. */
52ce6436
PH
7497 error (_("Cannot assign this kind of variant record"));
7498 }
7499 else if (*index_p == 0)
7500 return ada_value_primitive_field (arg, offset, i, type);
7501 else
7502 *index_p -= 1;
7503 }
7504 return NULL;
7505}
7506
4c4b4cd2
PH
7507/* Given ARG, a value of type (pointer or reference to a)*
7508 structure/union, extract the component named NAME from the ultimate
7509 target structure/union and return it as a value with its
f5938064 7510 appropriate type.
14f9c5c9 7511
4c4b4cd2
PH
7512 The routine searches for NAME among all members of the structure itself
7513 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7514 (e.g., '_parent').
7515
03ee6b2e
PH
7516 If NO_ERR, then simply return NULL in case of error, rather than
7517 calling error. */
14f9c5c9 7518
d2e4a39e 7519struct value *
a121b7c1 7520ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7521{
4c4b4cd2 7522 struct type *t, *t1;
d2e4a39e 7523 struct value *v;
14f9c5c9 7524
4c4b4cd2 7525 v = NULL;
df407dfe 7526 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7527 if (TYPE_CODE (t) == TYPE_CODE_REF)
7528 {
7529 t1 = TYPE_TARGET_TYPE (t);
7530 if (t1 == NULL)
03ee6b2e 7531 goto BadValue;
61ee279c 7532 t1 = ada_check_typedef (t1);
4c4b4cd2 7533 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7534 {
994b9211 7535 arg = coerce_ref (arg);
76a01679
JB
7536 t = t1;
7537 }
4c4b4cd2 7538 }
14f9c5c9 7539
4c4b4cd2
PH
7540 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7541 {
7542 t1 = TYPE_TARGET_TYPE (t);
7543 if (t1 == NULL)
03ee6b2e 7544 goto BadValue;
61ee279c 7545 t1 = ada_check_typedef (t1);
4c4b4cd2 7546 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7547 {
7548 arg = value_ind (arg);
7549 t = t1;
7550 }
4c4b4cd2 7551 else
76a01679 7552 break;
4c4b4cd2 7553 }
14f9c5c9 7554
4c4b4cd2 7555 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7556 goto BadValue;
14f9c5c9 7557
4c4b4cd2
PH
7558 if (t1 == t)
7559 v = ada_search_struct_field (name, arg, 0, t);
7560 else
7561 {
7562 int bit_offset, bit_size, byte_offset;
7563 struct type *field_type;
7564 CORE_ADDR address;
7565
76a01679 7566 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7567 address = value_address (ada_value_ind (arg));
4c4b4cd2 7568 else
b50d69b5 7569 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7570
828d5846
XR
7571 /* Check to see if this is a tagged type. We also need to handle
7572 the case where the type is a reference to a tagged type, but
7573 we have to be careful to exclude pointers to tagged types.
7574 The latter should be shown as usual (as a pointer), whereas
7575 a reference should mostly be transparent to the user. */
7576
7577 if (ada_is_tagged_type (t1, 0)
7578 || (TYPE_CODE (t1) == TYPE_CODE_REF
7579 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7580 {
7581 /* We first try to find the searched field in the current type.
7582 If not found then let's look in the fixed type. */
7583
7584 if (!find_struct_field (name, t1, 0,
7585 &field_type, &byte_offset, &bit_offset,
7586 &bit_size, NULL))
7587 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7588 address, NULL, 1);
7589 }
7590 else
7591 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7592 address, NULL, 1);
7593
76a01679
JB
7594 if (find_struct_field (name, t1, 0,
7595 &field_type, &byte_offset, &bit_offset,
52ce6436 7596 &bit_size, NULL))
76a01679
JB
7597 {
7598 if (bit_size != 0)
7599 {
714e53ab
PH
7600 if (TYPE_CODE (t) == TYPE_CODE_REF)
7601 arg = ada_coerce_ref (arg);
7602 else
7603 arg = ada_value_ind (arg);
76a01679
JB
7604 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7605 bit_offset, bit_size,
7606 field_type);
7607 }
7608 else
f5938064 7609 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7610 }
7611 }
7612
03ee6b2e
PH
7613 if (v != NULL || no_err)
7614 return v;
7615 else
323e0a4a 7616 error (_("There is no member named %s."), name);
14f9c5c9 7617
03ee6b2e
PH
7618 BadValue:
7619 if (no_err)
7620 return NULL;
7621 else
0963b4bd
MS
7622 error (_("Attempt to extract a component of "
7623 "a value that is not a record."));
14f9c5c9
AS
7624}
7625
3b4de39c 7626/* Return a string representation of type TYPE. */
99bbb428 7627
3b4de39c 7628static std::string
99bbb428
PA
7629type_as_string (struct type *type)
7630{
d7e74731 7631 string_file tmp_stream;
99bbb428 7632
d7e74731 7633 type_print (type, "", &tmp_stream, -1);
99bbb428 7634
d7e74731 7635 return std::move (tmp_stream.string ());
99bbb428
PA
7636}
7637
14f9c5c9 7638/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7639 If DISPP is non-null, add its byte displacement from the beginning of a
7640 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7641 work for packed fields).
7642
7643 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7644 followed by "___".
14f9c5c9 7645
0963b4bd 7646 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7647 be a (pointer or reference)+ to a struct or union, and the
7648 ultimate target type will be searched.
14f9c5c9
AS
7649
7650 Looks recursively into variant clauses and parent types.
7651
828d5846
XR
7652 In the case of homonyms in the tagged types, please refer to the
7653 long explanation in find_struct_field's function documentation.
7654
4c4b4cd2
PH
7655 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7656 TYPE is not a type of the right kind. */
14f9c5c9 7657
4c4b4cd2 7658static struct type *
a121b7c1 7659ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7660 int noerr)
14f9c5c9
AS
7661{
7662 int i;
828d5846 7663 int parent_offset = -1;
14f9c5c9
AS
7664
7665 if (name == NULL)
7666 goto BadName;
7667
76a01679 7668 if (refok && type != NULL)
4c4b4cd2
PH
7669 while (1)
7670 {
61ee279c 7671 type = ada_check_typedef (type);
76a01679
JB
7672 if (TYPE_CODE (type) != TYPE_CODE_PTR
7673 && TYPE_CODE (type) != TYPE_CODE_REF)
7674 break;
7675 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7676 }
14f9c5c9 7677
76a01679 7678 if (type == NULL
1265e4aa
JB
7679 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7680 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7681 {
4c4b4cd2 7682 if (noerr)
76a01679 7683 return NULL;
99bbb428 7684
3b4de39c
PA
7685 error (_("Type %s is not a structure or union type"),
7686 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7687 }
7688
7689 type = to_static_fixed_type (type);
7690
7691 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7692 {
0d5cff50 7693 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7694 struct type *t;
d2e4a39e 7695
14f9c5c9 7696 if (t_field_name == NULL)
4c4b4cd2 7697 continue;
14f9c5c9 7698
828d5846
XR
7699 else if (ada_is_parent_field (type, i))
7700 {
7701 /* This is a field pointing us to the parent type of a tagged
7702 type. As hinted in this function's documentation, we give
7703 preference to fields in the current record first, so what
7704 we do here is just record the index of this field before
7705 we skip it. If it turns out we couldn't find our field
7706 in the current record, then we'll get back to it and search
7707 inside it whether the field might exist in the parent. */
7708
7709 parent_offset = i;
7710 continue;
7711 }
7712
14f9c5c9 7713 else if (field_name_match (t_field_name, name))
988f6b3d 7714 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7715
7716 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7717 {
4c4b4cd2 7718 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7719 0, 1);
4c4b4cd2 7720 if (t != NULL)
988f6b3d 7721 return t;
4c4b4cd2 7722 }
14f9c5c9
AS
7723
7724 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7725 {
7726 int j;
5b4ee69b
MS
7727 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7728 i));
4c4b4cd2
PH
7729
7730 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7731 {
b1f33ddd
JB
7732 /* FIXME pnh 2008/01/26: We check for a field that is
7733 NOT wrapped in a struct, since the compiler sometimes
7734 generates these for unchecked variant types. Revisit
0963b4bd 7735 if the compiler changes this practice. */
0d5cff50 7736 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7737
b1f33ddd
JB
7738 if (v_field_name != NULL
7739 && field_name_match (v_field_name, name))
460efde1 7740 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7741 else
0963b4bd
MS
7742 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7743 j),
988f6b3d 7744 name, 0, 1);
b1f33ddd 7745
4c4b4cd2 7746 if (t != NULL)
988f6b3d 7747 return t;
4c4b4cd2
PH
7748 }
7749 }
14f9c5c9
AS
7750
7751 }
7752
828d5846
XR
7753 /* Field not found so far. If this is a tagged type which
7754 has a parent, try finding that field in the parent now. */
7755
7756 if (parent_offset != -1)
7757 {
7758 struct type *t;
7759
7760 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7761 name, 0, 1);
7762 if (t != NULL)
7763 return t;
7764 }
7765
14f9c5c9 7766BadName:
d2e4a39e 7767 if (!noerr)
14f9c5c9 7768 {
2b2798cc 7769 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7770
7771 error (_("Type %s has no component named %s"),
3b4de39c 7772 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7773 }
7774
7775 return NULL;
7776}
7777
b1f33ddd
JB
7778/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7779 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7780 represents an unchecked union (that is, the variant part of a
0963b4bd 7781 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7782
7783static int
7784is_unchecked_variant (struct type *var_type, struct type *outer_type)
7785{
a121b7c1 7786 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7787
988f6b3d 7788 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7789}
7790
7791
14f9c5c9
AS
7792/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7793 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7794 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7795 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7796
d2e4a39e 7797int
ebf56fd3 7798ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7799 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7800{
7801 int others_clause;
7802 int i;
a121b7c1 7803 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7804 struct value *outer;
7805 struct value *discrim;
14f9c5c9
AS
7806 LONGEST discrim_val;
7807
012370f6
TT
7808 /* Using plain value_from_contents_and_address here causes problems
7809 because we will end up trying to resolve a type that is currently
7810 being constructed. */
7811 outer = value_from_contents_and_address_unresolved (outer_type,
7812 outer_valaddr, 0);
0c281816
JB
7813 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7814 if (discrim == NULL)
14f9c5c9 7815 return -1;
0c281816 7816 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7817
7818 others_clause = -1;
7819 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7820 {
7821 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7822 others_clause = i;
14f9c5c9 7823 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7824 return i;
14f9c5c9
AS
7825 }
7826
7827 return others_clause;
7828}
d2e4a39e 7829\f
14f9c5c9
AS
7830
7831
4c4b4cd2 7832 /* Dynamic-Sized Records */
14f9c5c9
AS
7833
7834/* Strategy: The type ostensibly attached to a value with dynamic size
7835 (i.e., a size that is not statically recorded in the debugging
7836 data) does not accurately reflect the size or layout of the value.
7837 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7838 conventional types that are constructed on the fly. */
14f9c5c9
AS
7839
7840/* There is a subtle and tricky problem here. In general, we cannot
7841 determine the size of dynamic records without its data. However,
7842 the 'struct value' data structure, which GDB uses to represent
7843 quantities in the inferior process (the target), requires the size
7844 of the type at the time of its allocation in order to reserve space
7845 for GDB's internal copy of the data. That's why the
7846 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7847 rather than struct value*s.
14f9c5c9
AS
7848
7849 However, GDB's internal history variables ($1, $2, etc.) are
7850 struct value*s containing internal copies of the data that are not, in
7851 general, the same as the data at their corresponding addresses in
7852 the target. Fortunately, the types we give to these values are all
7853 conventional, fixed-size types (as per the strategy described
7854 above), so that we don't usually have to perform the
7855 'to_fixed_xxx_type' conversions to look at their values.
7856 Unfortunately, there is one exception: if one of the internal
7857 history variables is an array whose elements are unconstrained
7858 records, then we will need to create distinct fixed types for each
7859 element selected. */
7860
7861/* The upshot of all of this is that many routines take a (type, host
7862 address, target address) triple as arguments to represent a value.
7863 The host address, if non-null, is supposed to contain an internal
7864 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7865 target at the target address. */
14f9c5c9
AS
7866
7867/* Assuming that VAL0 represents a pointer value, the result of
7868 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7869 dynamic-sized types. */
14f9c5c9 7870
d2e4a39e
AS
7871struct value *
7872ada_value_ind (struct value *val0)
14f9c5c9 7873{
c48db5ca 7874 struct value *val = value_ind (val0);
5b4ee69b 7875
b50d69b5
JG
7876 if (ada_is_tagged_type (value_type (val), 0))
7877 val = ada_tag_value_at_base_address (val);
7878
4c4b4cd2 7879 return ada_to_fixed_value (val);
14f9c5c9
AS
7880}
7881
7882/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7883 qualifiers on VAL0. */
7884
d2e4a39e
AS
7885static struct value *
7886ada_coerce_ref (struct value *val0)
7887{
df407dfe 7888 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7889 {
7890 struct value *val = val0;
5b4ee69b 7891
994b9211 7892 val = coerce_ref (val);
b50d69b5
JG
7893
7894 if (ada_is_tagged_type (value_type (val), 0))
7895 val = ada_tag_value_at_base_address (val);
7896
4c4b4cd2 7897 return ada_to_fixed_value (val);
d2e4a39e
AS
7898 }
7899 else
14f9c5c9
AS
7900 return val0;
7901}
7902
7903/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7904 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7905
7906static unsigned int
ebf56fd3 7907align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7908{
7909 return (off + alignment - 1) & ~(alignment - 1);
7910}
7911
4c4b4cd2 7912/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7913
7914static unsigned int
ebf56fd3 7915field_alignment (struct type *type, int f)
14f9c5c9 7916{
d2e4a39e 7917 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7918 int len;
14f9c5c9
AS
7919 int align_offset;
7920
64a1bf19
JB
7921 /* The field name should never be null, unless the debugging information
7922 is somehow malformed. In this case, we assume the field does not
7923 require any alignment. */
7924 if (name == NULL)
7925 return 1;
7926
7927 len = strlen (name);
7928
4c4b4cd2
PH
7929 if (!isdigit (name[len - 1]))
7930 return 1;
14f9c5c9 7931
d2e4a39e 7932 if (isdigit (name[len - 2]))
14f9c5c9
AS
7933 align_offset = len - 2;
7934 else
7935 align_offset = len - 1;
7936
61012eef 7937 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7938 return TARGET_CHAR_BIT;
7939
4c4b4cd2
PH
7940 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7941}
7942
852dff6c 7943/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7944
852dff6c
JB
7945static struct symbol *
7946ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7947{
7948 struct symbol *sym;
7949
7950 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7951 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7952 return sym;
7953
4186eb54
KS
7954 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7955 return sym;
14f9c5c9
AS
7956}
7957
dddfab26
UW
7958/* Find a type named NAME. Ignores ambiguity. This routine will look
7959 solely for types defined by debug info, it will not search the GDB
7960 primitive types. */
4c4b4cd2 7961
852dff6c 7962static struct type *
ebf56fd3 7963ada_find_any_type (const char *name)
14f9c5c9 7964{
852dff6c 7965 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7966
14f9c5c9 7967 if (sym != NULL)
dddfab26 7968 return SYMBOL_TYPE (sym);
14f9c5c9 7969
dddfab26 7970 return NULL;
14f9c5c9
AS
7971}
7972
739593e0
JB
7973/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7974 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7975 symbol, in which case it is returned. Otherwise, this looks for
7976 symbols whose name is that of NAME_SYM suffixed with "___XR".
7977 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7978
7979struct symbol *
270140bd 7980ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7981{
739593e0 7982 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7983 struct symbol *sym;
7984
739593e0
JB
7985 if (strstr (name, "___XR") != NULL)
7986 return name_sym;
7987
aeb5907d
JB
7988 sym = find_old_style_renaming_symbol (name, block);
7989
7990 if (sym != NULL)
7991 return sym;
7992
0963b4bd 7993 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7994 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7995 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7996 return sym;
7997 else
7998 return NULL;
7999}
8000
8001static struct symbol *
270140bd 8002find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 8003{
7f0df278 8004 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
8005 char *rename;
8006
8007 if (function_sym != NULL)
8008 {
8009 /* If the symbol is defined inside a function, NAME is not fully
8010 qualified. This means we need to prepend the function name
8011 as well as adding the ``___XR'' suffix to build the name of
8012 the associated renaming symbol. */
0d5cff50 8013 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
8014 /* Function names sometimes contain suffixes used
8015 for instance to qualify nested subprograms. When building
8016 the XR type name, we need to make sure that this suffix is
8017 not included. So do not include any suffix in the function
8018 name length below. */
69fadcdf 8019 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
8020 const int rename_len = function_name_len + 2 /* "__" */
8021 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 8022
529cad9c 8023 /* Strip the suffix if necessary. */
69fadcdf
JB
8024 ada_remove_trailing_digits (function_name, &function_name_len);
8025 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8026 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 8027
4c4b4cd2
PH
8028 /* Library-level functions are a special case, as GNAT adds
8029 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 8030 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
8031 have this prefix, so we need to skip this prefix if present. */
8032 if (function_name_len > 5 /* "_ada_" */
8033 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
8034 {
8035 function_name += 5;
8036 function_name_len -= 5;
8037 }
4c4b4cd2
PH
8038
8039 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
8040 strncpy (rename, function_name, function_name_len);
8041 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8042 "__%s___XR", name);
4c4b4cd2
PH
8043 }
8044 else
8045 {
8046 const int rename_len = strlen (name) + 6;
5b4ee69b 8047
4c4b4cd2 8048 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 8049 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
8050 }
8051
852dff6c 8052 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
8053}
8054
14f9c5c9 8055/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 8056 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 8057 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
8058 otherwise return 0. */
8059
14f9c5c9 8060int
d2e4a39e 8061ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
8062{
8063 if (type1 == NULL)
8064 return 1;
8065 else if (type0 == NULL)
8066 return 0;
8067 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8068 return 1;
8069 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8070 return 0;
4c4b4cd2
PH
8071 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8072 return 1;
ad82864c 8073 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8074 return 1;
4c4b4cd2
PH
8075 else if (ada_is_array_descriptor_type (type0)
8076 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8077 return 1;
aeb5907d
JB
8078 else
8079 {
a737d952
TT
8080 const char *type0_name = TYPE_NAME (type0);
8081 const char *type1_name = TYPE_NAME (type1);
aeb5907d
JB
8082
8083 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8084 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8085 return 1;
8086 }
14f9c5c9
AS
8087 return 0;
8088}
8089
e86ca25f
TT
8090/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
8091 null. */
4c4b4cd2 8092
0d5cff50 8093const char *
d2e4a39e 8094ada_type_name (struct type *type)
14f9c5c9 8095{
d2e4a39e 8096 if (type == NULL)
14f9c5c9 8097 return NULL;
e86ca25f 8098 return TYPE_NAME (type);
14f9c5c9
AS
8099}
8100
b4ba55a1
JB
8101/* Search the list of "descriptive" types associated to TYPE for a type
8102 whose name is NAME. */
8103
8104static struct type *
8105find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8106{
931e5bc3 8107 struct type *result, *tmp;
b4ba55a1 8108
c6044dd1
JB
8109 if (ada_ignore_descriptive_types_p)
8110 return NULL;
8111
b4ba55a1
JB
8112 /* If there no descriptive-type info, then there is no parallel type
8113 to be found. */
8114 if (!HAVE_GNAT_AUX_INFO (type))
8115 return NULL;
8116
8117 result = TYPE_DESCRIPTIVE_TYPE (type);
8118 while (result != NULL)
8119 {
0d5cff50 8120 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8121
8122 if (result_name == NULL)
8123 {
8124 warning (_("unexpected null name on descriptive type"));
8125 return NULL;
8126 }
8127
8128 /* If the names match, stop. */
8129 if (strcmp (result_name, name) == 0)
8130 break;
8131
8132 /* Otherwise, look at the next item on the list, if any. */
8133 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8134 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8135 else
8136 tmp = NULL;
8137
8138 /* If not found either, try after having resolved the typedef. */
8139 if (tmp != NULL)
8140 result = tmp;
b4ba55a1 8141 else
931e5bc3 8142 {
f168693b 8143 result = check_typedef (result);
931e5bc3
JG
8144 if (HAVE_GNAT_AUX_INFO (result))
8145 result = TYPE_DESCRIPTIVE_TYPE (result);
8146 else
8147 result = NULL;
8148 }
b4ba55a1
JB
8149 }
8150
8151 /* If we didn't find a match, see whether this is a packed array. With
8152 older compilers, the descriptive type information is either absent or
8153 irrelevant when it comes to packed arrays so the above lookup fails.
8154 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8155 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8156 return ada_find_any_type (name);
8157
8158 return result;
8159}
8160
8161/* Find a parallel type to TYPE with the specified NAME, using the
8162 descriptive type taken from the debugging information, if available,
8163 and otherwise using the (slower) name-based method. */
8164
8165static struct type *
8166ada_find_parallel_type_with_name (struct type *type, const char *name)
8167{
8168 struct type *result = NULL;
8169
8170 if (HAVE_GNAT_AUX_INFO (type))
8171 result = find_parallel_type_by_descriptive_type (type, name);
8172 else
8173 result = ada_find_any_type (name);
8174
8175 return result;
8176}
8177
8178/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8179 SUFFIX to the name of TYPE. */
14f9c5c9 8180
d2e4a39e 8181struct type *
ebf56fd3 8182ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8183{
0d5cff50 8184 char *name;
fe978cb0 8185 const char *type_name = ada_type_name (type);
14f9c5c9 8186 int len;
d2e4a39e 8187
fe978cb0 8188 if (type_name == NULL)
14f9c5c9
AS
8189 return NULL;
8190
fe978cb0 8191 len = strlen (type_name);
14f9c5c9 8192
b4ba55a1 8193 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8194
fe978cb0 8195 strcpy (name, type_name);
14f9c5c9
AS
8196 strcpy (name + len, suffix);
8197
b4ba55a1 8198 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8199}
8200
14f9c5c9 8201/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8202 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8203
d2e4a39e
AS
8204static struct type *
8205dynamic_template_type (struct type *type)
14f9c5c9 8206{
61ee279c 8207 type = ada_check_typedef (type);
14f9c5c9
AS
8208
8209 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8210 || ada_type_name (type) == NULL)
14f9c5c9 8211 return NULL;
d2e4a39e 8212 else
14f9c5c9
AS
8213 {
8214 int len = strlen (ada_type_name (type));
5b4ee69b 8215
4c4b4cd2
PH
8216 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8217 return type;
14f9c5c9 8218 else
4c4b4cd2 8219 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8220 }
8221}
8222
8223/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8224 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8225
d2e4a39e
AS
8226static int
8227is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8228{
8229 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8230
d2e4a39e 8231 return name != NULL
14f9c5c9
AS
8232 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8233 && strstr (name, "___XVL") != NULL;
8234}
8235
4c4b4cd2
PH
8236/* The index of the variant field of TYPE, or -1 if TYPE does not
8237 represent a variant record type. */
14f9c5c9 8238
d2e4a39e 8239static int
4c4b4cd2 8240variant_field_index (struct type *type)
14f9c5c9
AS
8241{
8242 int f;
8243
4c4b4cd2
PH
8244 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8245 return -1;
8246
8247 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8248 {
8249 if (ada_is_variant_part (type, f))
8250 return f;
8251 }
8252 return -1;
14f9c5c9
AS
8253}
8254
4c4b4cd2
PH
8255/* A record type with no fields. */
8256
d2e4a39e 8257static struct type *
fe978cb0 8258empty_record (struct type *templ)
14f9c5c9 8259{
fe978cb0 8260 struct type *type = alloc_type_copy (templ);
5b4ee69b 8261
14f9c5c9
AS
8262 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8263 TYPE_NFIELDS (type) = 0;
8264 TYPE_FIELDS (type) = NULL;
b1f33ddd 8265 INIT_CPLUS_SPECIFIC (type);
14f9c5c9 8266 TYPE_NAME (type) = "<empty>";
14f9c5c9
AS
8267 TYPE_LENGTH (type) = 0;
8268 return type;
8269}
8270
8271/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8272 the value of type TYPE at VALADDR or ADDRESS (see comments at
8273 the beginning of this section) VAL according to GNAT conventions.
8274 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8275 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8276 an outer-level type (i.e., as opposed to a branch of a variant.) A
8277 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8278 of the variant.
14f9c5c9 8279
4c4b4cd2
PH
8280 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8281 length are not statically known are discarded. As a consequence,
8282 VALADDR, ADDRESS and DVAL0 are ignored.
8283
8284 NOTE: Limitations: For now, we assume that dynamic fields and
8285 variants occupy whole numbers of bytes. However, they need not be
8286 byte-aligned. */
8287
8288struct type *
10a2c479 8289ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8290 const gdb_byte *valaddr,
4c4b4cd2
PH
8291 CORE_ADDR address, struct value *dval0,
8292 int keep_dynamic_fields)
14f9c5c9 8293{
d2e4a39e
AS
8294 struct value *mark = value_mark ();
8295 struct value *dval;
8296 struct type *rtype;
14f9c5c9 8297 int nfields, bit_len;
4c4b4cd2 8298 int variant_field;
14f9c5c9 8299 long off;
d94e4f4f 8300 int fld_bit_len;
14f9c5c9
AS
8301 int f;
8302
4c4b4cd2
PH
8303 /* Compute the number of fields in this record type that are going
8304 to be processed: unless keep_dynamic_fields, this includes only
8305 fields whose position and length are static will be processed. */
8306 if (keep_dynamic_fields)
8307 nfields = TYPE_NFIELDS (type);
8308 else
8309 {
8310 nfields = 0;
76a01679 8311 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8312 && !ada_is_variant_part (type, nfields)
8313 && !is_dynamic_field (type, nfields))
8314 nfields++;
8315 }
8316
e9bb382b 8317 rtype = alloc_type_copy (type);
14f9c5c9
AS
8318 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8319 INIT_CPLUS_SPECIFIC (rtype);
8320 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8321 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8322 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8323 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8324 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8325 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8326
d2e4a39e
AS
8327 off = 0;
8328 bit_len = 0;
4c4b4cd2
PH
8329 variant_field = -1;
8330
14f9c5c9
AS
8331 for (f = 0; f < nfields; f += 1)
8332 {
6c038f32
PH
8333 off = align_value (off, field_alignment (type, f))
8334 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8335 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8336 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8337
d2e4a39e 8338 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8339 {
8340 variant_field = f;
d94e4f4f 8341 fld_bit_len = 0;
4c4b4cd2 8342 }
14f9c5c9 8343 else if (is_dynamic_field (type, f))
4c4b4cd2 8344 {
284614f0
JB
8345 const gdb_byte *field_valaddr = valaddr;
8346 CORE_ADDR field_address = address;
8347 struct type *field_type =
8348 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8349
4c4b4cd2 8350 if (dval0 == NULL)
b5304971
JG
8351 {
8352 /* rtype's length is computed based on the run-time
8353 value of discriminants. If the discriminants are not
8354 initialized, the type size may be completely bogus and
0963b4bd 8355 GDB may fail to allocate a value for it. So check the
b5304971 8356 size first before creating the value. */
c1b5a1a6 8357 ada_ensure_varsize_limit (rtype);
012370f6
TT
8358 /* Using plain value_from_contents_and_address here
8359 causes problems because we will end up trying to
8360 resolve a type that is currently being
8361 constructed. */
8362 dval = value_from_contents_and_address_unresolved (rtype,
8363 valaddr,
8364 address);
9f1f738a 8365 rtype = value_type (dval);
b5304971 8366 }
4c4b4cd2
PH
8367 else
8368 dval = dval0;
8369
284614f0
JB
8370 /* If the type referenced by this field is an aligner type, we need
8371 to unwrap that aligner type, because its size might not be set.
8372 Keeping the aligner type would cause us to compute the wrong
8373 size for this field, impacting the offset of the all the fields
8374 that follow this one. */
8375 if (ada_is_aligner_type (field_type))
8376 {
8377 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8378
8379 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8380 field_address = cond_offset_target (field_address, field_offset);
8381 field_type = ada_aligned_type (field_type);
8382 }
8383
8384 field_valaddr = cond_offset_host (field_valaddr,
8385 off / TARGET_CHAR_BIT);
8386 field_address = cond_offset_target (field_address,
8387 off / TARGET_CHAR_BIT);
8388
8389 /* Get the fixed type of the field. Note that, in this case,
8390 we do not want to get the real type out of the tag: if
8391 the current field is the parent part of a tagged record,
8392 we will get the tag of the object. Clearly wrong: the real
8393 type of the parent is not the real type of the child. We
8394 would end up in an infinite loop. */
8395 field_type = ada_get_base_type (field_type);
8396 field_type = ada_to_fixed_type (field_type, field_valaddr,
8397 field_address, dval, 0);
27f2a97b
JB
8398 /* If the field size is already larger than the maximum
8399 object size, then the record itself will necessarily
8400 be larger than the maximum object size. We need to make
8401 this check now, because the size might be so ridiculously
8402 large (due to an uninitialized variable in the inferior)
8403 that it would cause an overflow when adding it to the
8404 record size. */
c1b5a1a6 8405 ada_ensure_varsize_limit (field_type);
284614f0
JB
8406
8407 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8408 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8409 /* The multiplication can potentially overflow. But because
8410 the field length has been size-checked just above, and
8411 assuming that the maximum size is a reasonable value,
8412 an overflow should not happen in practice. So rather than
8413 adding overflow recovery code to this already complex code,
8414 we just assume that it's not going to happen. */
d94e4f4f 8415 fld_bit_len =
4c4b4cd2
PH
8416 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8417 }
14f9c5c9 8418 else
4c4b4cd2 8419 {
5ded5331
JB
8420 /* Note: If this field's type is a typedef, it is important
8421 to preserve the typedef layer.
8422
8423 Otherwise, we might be transforming a typedef to a fat
8424 pointer (encoding a pointer to an unconstrained array),
8425 into a basic fat pointer (encoding an unconstrained
8426 array). As both types are implemented using the same
8427 structure, the typedef is the only clue which allows us
8428 to distinguish between the two options. Stripping it
8429 would prevent us from printing this field appropriately. */
8430 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8431 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8432 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8433 fld_bit_len =
4c4b4cd2
PH
8434 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8435 else
5ded5331
JB
8436 {
8437 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8438
8439 /* We need to be careful of typedefs when computing
8440 the length of our field. If this is a typedef,
8441 get the length of the target type, not the length
8442 of the typedef. */
8443 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8444 field_type = ada_typedef_target_type (field_type);
8445
8446 fld_bit_len =
8447 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8448 }
4c4b4cd2 8449 }
14f9c5c9 8450 if (off + fld_bit_len > bit_len)
4c4b4cd2 8451 bit_len = off + fld_bit_len;
d94e4f4f 8452 off += fld_bit_len;
4c4b4cd2
PH
8453 TYPE_LENGTH (rtype) =
8454 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8455 }
4c4b4cd2
PH
8456
8457 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8458 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8459 the record. This can happen in the presence of representation
8460 clauses. */
8461 if (variant_field >= 0)
8462 {
8463 struct type *branch_type;
8464
8465 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8466
8467 if (dval0 == NULL)
9f1f738a 8468 {
012370f6
TT
8469 /* Using plain value_from_contents_and_address here causes
8470 problems because we will end up trying to resolve a type
8471 that is currently being constructed. */
8472 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8473 address);
9f1f738a
SA
8474 rtype = value_type (dval);
8475 }
4c4b4cd2
PH
8476 else
8477 dval = dval0;
8478
8479 branch_type =
8480 to_fixed_variant_branch_type
8481 (TYPE_FIELD_TYPE (type, variant_field),
8482 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8483 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8484 if (branch_type == NULL)
8485 {
8486 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8487 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8488 TYPE_NFIELDS (rtype) -= 1;
8489 }
8490 else
8491 {
8492 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8493 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8494 fld_bit_len =
8495 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8496 TARGET_CHAR_BIT;
8497 if (off + fld_bit_len > bit_len)
8498 bit_len = off + fld_bit_len;
8499 TYPE_LENGTH (rtype) =
8500 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8501 }
8502 }
8503
714e53ab
PH
8504 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8505 should contain the alignment of that record, which should be a strictly
8506 positive value. If null or negative, then something is wrong, most
8507 probably in the debug info. In that case, we don't round up the size
0963b4bd 8508 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8509 the current RTYPE length might be good enough for our purposes. */
8510 if (TYPE_LENGTH (type) <= 0)
8511 {
323e0a4a
AC
8512 if (TYPE_NAME (rtype))
8513 warning (_("Invalid type size for `%s' detected: %d."),
8514 TYPE_NAME (rtype), TYPE_LENGTH (type));
8515 else
8516 warning (_("Invalid type size for <unnamed> detected: %d."),
8517 TYPE_LENGTH (type));
714e53ab
PH
8518 }
8519 else
8520 {
8521 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8522 TYPE_LENGTH (type));
8523 }
14f9c5c9
AS
8524
8525 value_free_to_mark (mark);
d2e4a39e 8526 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8527 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8528 return rtype;
8529}
8530
4c4b4cd2
PH
8531/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8532 of 1. */
14f9c5c9 8533
d2e4a39e 8534static struct type *
fc1a4b47 8535template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8536 CORE_ADDR address, struct value *dval0)
8537{
8538 return ada_template_to_fixed_record_type_1 (type, valaddr,
8539 address, dval0, 1);
8540}
8541
8542/* An ordinary record type in which ___XVL-convention fields and
8543 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8544 static approximations, containing all possible fields. Uses
8545 no runtime values. Useless for use in values, but that's OK,
8546 since the results are used only for type determinations. Works on both
8547 structs and unions. Representation note: to save space, we memorize
8548 the result of this function in the TYPE_TARGET_TYPE of the
8549 template type. */
8550
8551static struct type *
8552template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8553{
8554 struct type *type;
8555 int nfields;
8556 int f;
8557
9e195661
PMR
8558 /* No need no do anything if the input type is already fixed. */
8559 if (TYPE_FIXED_INSTANCE (type0))
8560 return type0;
8561
8562 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8563 if (TYPE_TARGET_TYPE (type0) != NULL)
8564 return TYPE_TARGET_TYPE (type0);
8565
9e195661 8566 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8567 type = type0;
9e195661
PMR
8568 nfields = TYPE_NFIELDS (type0);
8569
8570 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8571 recompute all over next time. */
8572 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8573
8574 for (f = 0; f < nfields; f += 1)
8575 {
460efde1 8576 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8577 struct type *new_type;
14f9c5c9 8578
4c4b4cd2 8579 if (is_dynamic_field (type0, f))
460efde1
JB
8580 {
8581 field_type = ada_check_typedef (field_type);
8582 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8583 }
14f9c5c9 8584 else
f192137b 8585 new_type = static_unwrap_type (field_type);
9e195661
PMR
8586
8587 if (new_type != field_type)
8588 {
8589 /* Clone TYPE0 only the first time we get a new field type. */
8590 if (type == type0)
8591 {
8592 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8593 TYPE_CODE (type) = TYPE_CODE (type0);
8594 INIT_CPLUS_SPECIFIC (type);
8595 TYPE_NFIELDS (type) = nfields;
8596 TYPE_FIELDS (type) = (struct field *)
8597 TYPE_ALLOC (type, nfields * sizeof (struct field));
8598 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8599 sizeof (struct field) * nfields);
8600 TYPE_NAME (type) = ada_type_name (type0);
9e195661
PMR
8601 TYPE_FIXED_INSTANCE (type) = 1;
8602 TYPE_LENGTH (type) = 0;
8603 }
8604 TYPE_FIELD_TYPE (type, f) = new_type;
8605 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8606 }
14f9c5c9 8607 }
9e195661 8608
14f9c5c9
AS
8609 return type;
8610}
8611
4c4b4cd2 8612/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8613 whose address in memory is ADDRESS, returns a revision of TYPE,
8614 which should be a non-dynamic-sized record, in which the variant
8615 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8616 for discriminant values in DVAL0, which can be NULL if the record
8617 contains the necessary discriminant values. */
8618
d2e4a39e 8619static struct type *
fc1a4b47 8620to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8621 CORE_ADDR address, struct value *dval0)
14f9c5c9 8622{
d2e4a39e 8623 struct value *mark = value_mark ();
4c4b4cd2 8624 struct value *dval;
d2e4a39e 8625 struct type *rtype;
14f9c5c9
AS
8626 struct type *branch_type;
8627 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8628 int variant_field = variant_field_index (type);
14f9c5c9 8629
4c4b4cd2 8630 if (variant_field == -1)
14f9c5c9
AS
8631 return type;
8632
4c4b4cd2 8633 if (dval0 == NULL)
9f1f738a
SA
8634 {
8635 dval = value_from_contents_and_address (type, valaddr, address);
8636 type = value_type (dval);
8637 }
4c4b4cd2
PH
8638 else
8639 dval = dval0;
8640
e9bb382b 8641 rtype = alloc_type_copy (type);
14f9c5c9 8642 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8643 INIT_CPLUS_SPECIFIC (rtype);
8644 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8645 TYPE_FIELDS (rtype) =
8646 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8647 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8648 sizeof (struct field) * nfields);
14f9c5c9 8649 TYPE_NAME (rtype) = ada_type_name (type);
876cecd0 8650 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8651 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8652
4c4b4cd2
PH
8653 branch_type = to_fixed_variant_branch_type
8654 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8655 cond_offset_host (valaddr,
4c4b4cd2
PH
8656 TYPE_FIELD_BITPOS (type, variant_field)
8657 / TARGET_CHAR_BIT),
d2e4a39e 8658 cond_offset_target (address,
4c4b4cd2
PH
8659 TYPE_FIELD_BITPOS (type, variant_field)
8660 / TARGET_CHAR_BIT), dval);
d2e4a39e 8661 if (branch_type == NULL)
14f9c5c9 8662 {
4c4b4cd2 8663 int f;
5b4ee69b 8664
4c4b4cd2
PH
8665 for (f = variant_field + 1; f < nfields; f += 1)
8666 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8667 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8668 }
8669 else
8670 {
4c4b4cd2
PH
8671 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8672 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8673 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8674 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8675 }
4c4b4cd2 8676 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8677
4c4b4cd2 8678 value_free_to_mark (mark);
14f9c5c9
AS
8679 return rtype;
8680}
8681
8682/* An ordinary record type (with fixed-length fields) that describes
8683 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8684 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8685 should be in DVAL, a record value; it may be NULL if the object
8686 at ADDR itself contains any necessary discriminant values.
8687 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8688 values from the record are needed. Except in the case that DVAL,
8689 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8690 unchecked) is replaced by a particular branch of the variant.
8691
8692 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8693 is questionable and may be removed. It can arise during the
8694 processing of an unconstrained-array-of-record type where all the
8695 variant branches have exactly the same size. This is because in
8696 such cases, the compiler does not bother to use the XVS convention
8697 when encoding the record. I am currently dubious of this
8698 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8699
d2e4a39e 8700static struct type *
fc1a4b47 8701to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8702 CORE_ADDR address, struct value *dval)
14f9c5c9 8703{
d2e4a39e 8704 struct type *templ_type;
14f9c5c9 8705
876cecd0 8706 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8707 return type0;
8708
d2e4a39e 8709 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8710
8711 if (templ_type != NULL)
8712 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8713 else if (variant_field_index (type0) >= 0)
8714 {
8715 if (dval == NULL && valaddr == NULL && address == 0)
8716 return type0;
8717 return to_record_with_fixed_variant_part (type0, valaddr, address,
8718 dval);
8719 }
14f9c5c9
AS
8720 else
8721 {
876cecd0 8722 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8723 return type0;
8724 }
8725
8726}
8727
8728/* An ordinary record type (with fixed-length fields) that describes
8729 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8730 union type. Any necessary discriminants' values should be in DVAL,
8731 a record value. That is, this routine selects the appropriate
8732 branch of the union at ADDR according to the discriminant value
b1f33ddd 8733 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8734 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8735
d2e4a39e 8736static struct type *
fc1a4b47 8737to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8738 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8739{
8740 int which;
d2e4a39e
AS
8741 struct type *templ_type;
8742 struct type *var_type;
14f9c5c9
AS
8743
8744 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8745 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8746 else
14f9c5c9
AS
8747 var_type = var_type0;
8748
8749 templ_type = ada_find_parallel_type (var_type, "___XVU");
8750
8751 if (templ_type != NULL)
8752 var_type = templ_type;
8753
b1f33ddd
JB
8754 if (is_unchecked_variant (var_type, value_type (dval)))
8755 return var_type0;
d2e4a39e
AS
8756 which =
8757 ada_which_variant_applies (var_type,
0fd88904 8758 value_type (dval), value_contents (dval));
14f9c5c9
AS
8759
8760 if (which < 0)
e9bb382b 8761 return empty_record (var_type);
14f9c5c9 8762 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8763 return to_fixed_record_type
d2e4a39e
AS
8764 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8765 valaddr, address, dval);
4c4b4cd2 8766 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8767 return
8768 to_fixed_record_type
8769 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8770 else
8771 return TYPE_FIELD_TYPE (var_type, which);
8772}
8773
8908fca5
JB
8774/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8775 ENCODING_TYPE, a type following the GNAT conventions for discrete
8776 type encodings, only carries redundant information. */
8777
8778static int
8779ada_is_redundant_range_encoding (struct type *range_type,
8780 struct type *encoding_type)
8781{
108d56a4 8782 const char *bounds_str;
8908fca5
JB
8783 int n;
8784 LONGEST lo, hi;
8785
8786 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8787
005e2509
JB
8788 if (TYPE_CODE (get_base_type (range_type))
8789 != TYPE_CODE (get_base_type (encoding_type)))
8790 {
8791 /* The compiler probably used a simple base type to describe
8792 the range type instead of the range's actual base type,
8793 expecting us to get the real base type from the encoding
8794 anyway. In this situation, the encoding cannot be ignored
8795 as redundant. */
8796 return 0;
8797 }
8798
8908fca5
JB
8799 if (is_dynamic_type (range_type))
8800 return 0;
8801
8802 if (TYPE_NAME (encoding_type) == NULL)
8803 return 0;
8804
8805 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8806 if (bounds_str == NULL)
8807 return 0;
8808
8809 n = 8; /* Skip "___XDLU_". */
8810 if (!ada_scan_number (bounds_str, n, &lo, &n))
8811 return 0;
8812 if (TYPE_LOW_BOUND (range_type) != lo)
8813 return 0;
8814
8815 n += 2; /* Skip the "__" separator between the two bounds. */
8816 if (!ada_scan_number (bounds_str, n, &hi, &n))
8817 return 0;
8818 if (TYPE_HIGH_BOUND (range_type) != hi)
8819 return 0;
8820
8821 return 1;
8822}
8823
8824/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8825 a type following the GNAT encoding for describing array type
8826 indices, only carries redundant information. */
8827
8828static int
8829ada_is_redundant_index_type_desc (struct type *array_type,
8830 struct type *desc_type)
8831{
8832 struct type *this_layer = check_typedef (array_type);
8833 int i;
8834
8835 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8836 {
8837 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8838 TYPE_FIELD_TYPE (desc_type, i)))
8839 return 0;
8840 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8841 }
8842
8843 return 1;
8844}
8845
14f9c5c9
AS
8846/* Assuming that TYPE0 is an array type describing the type of a value
8847 at ADDR, and that DVAL describes a record containing any
8848 discriminants used in TYPE0, returns a type for the value that
8849 contains no dynamic components (that is, no components whose sizes
8850 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8851 true, gives an error message if the resulting type's size is over
4c4b4cd2 8852 varsize_limit. */
14f9c5c9 8853
d2e4a39e
AS
8854static struct type *
8855to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8856 int ignore_too_big)
14f9c5c9 8857{
d2e4a39e
AS
8858 struct type *index_type_desc;
8859 struct type *result;
ad82864c 8860 int constrained_packed_array_p;
931e5bc3 8861 static const char *xa_suffix = "___XA";
14f9c5c9 8862
b0dd7688 8863 type0 = ada_check_typedef (type0);
284614f0 8864 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8865 return type0;
14f9c5c9 8866
ad82864c
JB
8867 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8868 if (constrained_packed_array_p)
8869 type0 = decode_constrained_packed_array_type (type0);
284614f0 8870
931e5bc3
JG
8871 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8872
8873 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8874 encoding suffixed with 'P' may still be generated. If so,
8875 it should be used to find the XA type. */
8876
8877 if (index_type_desc == NULL)
8878 {
1da0522e 8879 const char *type_name = ada_type_name (type0);
931e5bc3 8880
1da0522e 8881 if (type_name != NULL)
931e5bc3 8882 {
1da0522e 8883 const int len = strlen (type_name);
931e5bc3
JG
8884 char *name = (char *) alloca (len + strlen (xa_suffix));
8885
1da0522e 8886 if (type_name[len - 1] == 'P')
931e5bc3 8887 {
1da0522e 8888 strcpy (name, type_name);
931e5bc3
JG
8889 strcpy (name + len - 1, xa_suffix);
8890 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8891 }
8892 }
8893 }
8894
28c85d6c 8895 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8896 if (index_type_desc != NULL
8897 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8898 {
8899 /* Ignore this ___XA parallel type, as it does not bring any
8900 useful information. This allows us to avoid creating fixed
8901 versions of the array's index types, which would be identical
8902 to the original ones. This, in turn, can also help avoid
8903 the creation of fixed versions of the array itself. */
8904 index_type_desc = NULL;
8905 }
8906
14f9c5c9
AS
8907 if (index_type_desc == NULL)
8908 {
61ee279c 8909 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8910
14f9c5c9 8911 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8912 depend on the contents of the array in properly constructed
8913 debugging data. */
529cad9c
PH
8914 /* Create a fixed version of the array element type.
8915 We're not providing the address of an element here,
e1d5a0d2 8916 and thus the actual object value cannot be inspected to do
529cad9c
PH
8917 the conversion. This should not be a problem, since arrays of
8918 unconstrained objects are not allowed. In particular, all
8919 the elements of an array of a tagged type should all be of
8920 the same type specified in the debugging info. No need to
8921 consult the object tag. */
1ed6ede0 8922 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8923
284614f0
JB
8924 /* Make sure we always create a new array type when dealing with
8925 packed array types, since we're going to fix-up the array
8926 type length and element bitsize a little further down. */
ad82864c 8927 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8928 result = type0;
14f9c5c9 8929 else
e9bb382b 8930 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8931 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8932 }
8933 else
8934 {
8935 int i;
8936 struct type *elt_type0;
8937
8938 elt_type0 = type0;
8939 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8940 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8941
8942 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8943 depend on the contents of the array in properly constructed
8944 debugging data. */
529cad9c
PH
8945 /* Create a fixed version of the array element type.
8946 We're not providing the address of an element here,
e1d5a0d2 8947 and thus the actual object value cannot be inspected to do
529cad9c
PH
8948 the conversion. This should not be a problem, since arrays of
8949 unconstrained objects are not allowed. In particular, all
8950 the elements of an array of a tagged type should all be of
8951 the same type specified in the debugging info. No need to
8952 consult the object tag. */
1ed6ede0
JB
8953 result =
8954 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8955
8956 elt_type0 = type0;
14f9c5c9 8957 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8958 {
8959 struct type *range_type =
28c85d6c 8960 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8961
e9bb382b 8962 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8963 result, range_type);
1ce677a4 8964 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8965 }
d2e4a39e 8966 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8967 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8968 }
8969
2e6fda7d
JB
8970 /* We want to preserve the type name. This can be useful when
8971 trying to get the type name of a value that has already been
8972 printed (for instance, if the user did "print VAR; whatis $". */
8973 TYPE_NAME (result) = TYPE_NAME (type0);
8974
ad82864c 8975 if (constrained_packed_array_p)
284614f0
JB
8976 {
8977 /* So far, the resulting type has been created as if the original
8978 type was a regular (non-packed) array type. As a result, the
8979 bitsize of the array elements needs to be set again, and the array
8980 length needs to be recomputed based on that bitsize. */
8981 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8982 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8983
8984 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8985 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8986 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8987 TYPE_LENGTH (result)++;
8988 }
8989
876cecd0 8990 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8991 return result;
d2e4a39e 8992}
14f9c5c9
AS
8993
8994
8995/* A standard type (containing no dynamically sized components)
8996 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8997 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8998 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8999 ADDRESS or in VALADDR contains these discriminants.
9000
1ed6ede0
JB
9001 If CHECK_TAG is not null, in the case of tagged types, this function
9002 attempts to locate the object's tag and use it to compute the actual
9003 type. However, when ADDRESS is null, we cannot use it to determine the
9004 location of the tag, and therefore compute the tagged type's actual type.
9005 So we return the tagged type without consulting the tag. */
529cad9c 9006
f192137b
JB
9007static struct type *
9008ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 9009 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 9010{
61ee279c 9011 type = ada_check_typedef (type);
d2e4a39e
AS
9012 switch (TYPE_CODE (type))
9013 {
9014 default:
14f9c5c9 9015 return type;
d2e4a39e 9016 case TYPE_CODE_STRUCT:
4c4b4cd2 9017 {
76a01679 9018 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
9019 struct type *fixed_record_type =
9020 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 9021
529cad9c
PH
9022 /* If STATIC_TYPE is a tagged type and we know the object's address,
9023 then we can determine its tag, and compute the object's actual
0963b4bd 9024 type from there. Note that we have to use the fixed record
1ed6ede0
JB
9025 type (the parent part of the record may have dynamic fields
9026 and the way the location of _tag is expressed may depend on
9027 them). */
529cad9c 9028
1ed6ede0 9029 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 9030 {
b50d69b5
JG
9031 struct value *tag =
9032 value_tag_from_contents_and_address
9033 (fixed_record_type,
9034 valaddr,
9035 address);
9036 struct type *real_type = type_from_tag (tag);
9037 struct value *obj =
9038 value_from_contents_and_address (fixed_record_type,
9039 valaddr,
9040 address);
9f1f738a 9041 fixed_record_type = value_type (obj);
76a01679 9042 if (real_type != NULL)
b50d69b5
JG
9043 return to_fixed_record_type
9044 (real_type, NULL,
9045 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 9046 }
4af88198
JB
9047
9048 /* Check to see if there is a parallel ___XVZ variable.
9049 If there is, then it provides the actual size of our type. */
9050 else if (ada_type_name (fixed_record_type) != NULL)
9051 {
0d5cff50 9052 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
9053 char *xvz_name
9054 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
eccab96d 9055 bool xvz_found = false;
4af88198
JB
9056 LONGEST size;
9057
88c15c34 9058 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
eccab96d
JB
9059 TRY
9060 {
9061 xvz_found = get_int_var_value (xvz_name, size);
9062 }
9063 CATCH (except, RETURN_MASK_ERROR)
9064 {
9065 /* We found the variable, but somehow failed to read
9066 its value. Rethrow the same error, but with a little
9067 bit more information, to help the user understand
9068 what went wrong (Eg: the variable might have been
9069 optimized out). */
9070 throw_error (except.error,
9071 _("unable to read value of %s (%s)"),
9072 xvz_name, except.message);
9073 }
9074 END_CATCH
9075
9076 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
9077 {
9078 fixed_record_type = copy_type (fixed_record_type);
9079 TYPE_LENGTH (fixed_record_type) = size;
9080
9081 /* The FIXED_RECORD_TYPE may have be a stub. We have
9082 observed this when the debugging info is STABS, and
9083 apparently it is something that is hard to fix.
9084
9085 In practice, we don't need the actual type definition
9086 at all, because the presence of the XVZ variable allows us
9087 to assume that there must be a XVS type as well, which we
9088 should be able to use later, when we need the actual type
9089 definition.
9090
9091 In the meantime, pretend that the "fixed" type we are
9092 returning is NOT a stub, because this can cause trouble
9093 when using this type to create new types targeting it.
9094 Indeed, the associated creation routines often check
9095 whether the target type is a stub and will try to replace
0963b4bd 9096 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9097 might cause the new type to have the wrong size too.
9098 Consider the case of an array, for instance, where the size
9099 of the array is computed from the number of elements in
9100 our array multiplied by the size of its element. */
9101 TYPE_STUB (fixed_record_type) = 0;
9102 }
9103 }
1ed6ede0 9104 return fixed_record_type;
4c4b4cd2 9105 }
d2e4a39e 9106 case TYPE_CODE_ARRAY:
4c4b4cd2 9107 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9108 case TYPE_CODE_UNION:
9109 if (dval == NULL)
4c4b4cd2 9110 return type;
d2e4a39e 9111 else
4c4b4cd2 9112 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9113 }
14f9c5c9
AS
9114}
9115
f192137b
JB
9116/* The same as ada_to_fixed_type_1, except that it preserves the type
9117 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9118
9119 The typedef layer needs be preserved in order to differentiate between
9120 arrays and array pointers when both types are implemented using the same
9121 fat pointer. In the array pointer case, the pointer is encoded as
9122 a typedef of the pointer type. For instance, considering:
9123
9124 type String_Access is access String;
9125 S1 : String_Access := null;
9126
9127 To the debugger, S1 is defined as a typedef of type String. But
9128 to the user, it is a pointer. So if the user tries to print S1,
9129 we should not dereference the array, but print the array address
9130 instead.
9131
9132 If we didn't preserve the typedef layer, we would lose the fact that
9133 the type is to be presented as a pointer (needs de-reference before
9134 being printed). And we would also use the source-level type name. */
f192137b
JB
9135
9136struct type *
9137ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9138 CORE_ADDR address, struct value *dval, int check_tag)
9139
9140{
9141 struct type *fixed_type =
9142 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9143
96dbd2c1
JB
9144 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9145 then preserve the typedef layer.
9146
9147 Implementation note: We can only check the main-type portion of
9148 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9149 from TYPE now returns a type that has the same instance flags
9150 as TYPE. For instance, if TYPE is a "typedef const", and its
9151 target type is a "struct", then the typedef elimination will return
9152 a "const" version of the target type. See check_typedef for more
9153 details about how the typedef layer elimination is done.
9154
9155 brobecker/2010-11-19: It seems to me that the only case where it is
9156 useful to preserve the typedef layer is when dealing with fat pointers.
9157 Perhaps, we could add a check for that and preserve the typedef layer
9158 only in that situation. But this seems unecessary so far, probably
9159 because we call check_typedef/ada_check_typedef pretty much everywhere.
9160 */
f192137b 9161 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9162 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9163 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9164 return type;
9165
9166 return fixed_type;
9167}
9168
14f9c5c9 9169/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9170 TYPE0, but based on no runtime data. */
14f9c5c9 9171
d2e4a39e
AS
9172static struct type *
9173to_static_fixed_type (struct type *type0)
14f9c5c9 9174{
d2e4a39e 9175 struct type *type;
14f9c5c9
AS
9176
9177 if (type0 == NULL)
9178 return NULL;
9179
876cecd0 9180 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9181 return type0;
9182
61ee279c 9183 type0 = ada_check_typedef (type0);
d2e4a39e 9184
14f9c5c9
AS
9185 switch (TYPE_CODE (type0))
9186 {
9187 default:
9188 return type0;
9189 case TYPE_CODE_STRUCT:
9190 type = dynamic_template_type (type0);
d2e4a39e 9191 if (type != NULL)
4c4b4cd2
PH
9192 return template_to_static_fixed_type (type);
9193 else
9194 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9195 case TYPE_CODE_UNION:
9196 type = ada_find_parallel_type (type0, "___XVU");
9197 if (type != NULL)
4c4b4cd2
PH
9198 return template_to_static_fixed_type (type);
9199 else
9200 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9201 }
9202}
9203
4c4b4cd2
PH
9204/* A static approximation of TYPE with all type wrappers removed. */
9205
d2e4a39e
AS
9206static struct type *
9207static_unwrap_type (struct type *type)
14f9c5c9
AS
9208{
9209 if (ada_is_aligner_type (type))
9210 {
61ee279c 9211 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9212 if (ada_type_name (type1) == NULL)
4c4b4cd2 9213 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9214
9215 return static_unwrap_type (type1);
9216 }
d2e4a39e 9217 else
14f9c5c9 9218 {
d2e4a39e 9219 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9220
d2e4a39e 9221 if (raw_real_type == type)
4c4b4cd2 9222 return type;
14f9c5c9 9223 else
4c4b4cd2 9224 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9225 }
9226}
9227
9228/* In some cases, incomplete and private types require
4c4b4cd2 9229 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9230 type Foo;
9231 type FooP is access Foo;
9232 V: FooP;
9233 type Foo is array ...;
4c4b4cd2 9234 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9235 cross-references to such types, we instead substitute for FooP a
9236 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9237 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9238
9239/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9240 exists, otherwise TYPE. */
9241
d2e4a39e 9242struct type *
61ee279c 9243ada_check_typedef (struct type *type)
14f9c5c9 9244{
727e3d2e
JB
9245 if (type == NULL)
9246 return NULL;
9247
720d1a40
JB
9248 /* If our type is a typedef type of a fat pointer, then we're done.
9249 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9250 what allows us to distinguish between fat pointers that represent
9251 array types, and fat pointers that represent array access types
9252 (in both cases, the compiler implements them as fat pointers). */
9253 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9254 && is_thick_pntr (ada_typedef_target_type (type)))
9255 return type;
9256
f168693b 9257 type = check_typedef (type);
14f9c5c9 9258 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9259 || !TYPE_STUB (type)
e86ca25f 9260 || TYPE_NAME (type) == NULL)
14f9c5c9 9261 return type;
d2e4a39e 9262 else
14f9c5c9 9263 {
e86ca25f 9264 const char *name = TYPE_NAME (type);
d2e4a39e 9265 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9266
05e522ef
JB
9267 if (type1 == NULL)
9268 return type;
9269
9270 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9271 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9272 types, only for the typedef-to-array types). If that's the case,
9273 strip the typedef layer. */
9274 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9275 type1 = ada_check_typedef (type1);
9276
9277 return type1;
14f9c5c9
AS
9278 }
9279}
9280
9281/* A value representing the data at VALADDR/ADDRESS as described by
9282 type TYPE0, but with a standard (static-sized) type that correctly
9283 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9284 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9285 creation of struct values]. */
14f9c5c9 9286
4c4b4cd2
PH
9287static struct value *
9288ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9289 struct value *val0)
14f9c5c9 9290{
1ed6ede0 9291 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9292
14f9c5c9
AS
9293 if (type == type0 && val0 != NULL)
9294 return val0;
cc0e770c
JB
9295
9296 if (VALUE_LVAL (val0) != lval_memory)
9297 {
9298 /* Our value does not live in memory; it could be a convenience
9299 variable, for instance. Create a not_lval value using val0's
9300 contents. */
9301 return value_from_contents (type, value_contents (val0));
9302 }
9303
9304 return value_from_contents_and_address (type, 0, address);
4c4b4cd2
PH
9305}
9306
9307/* A value representing VAL, but with a standard (static-sized) type
9308 that correctly describes it. Does not necessarily create a new
9309 value. */
9310
0c3acc09 9311struct value *
4c4b4cd2
PH
9312ada_to_fixed_value (struct value *val)
9313{
c48db5ca 9314 val = unwrap_value (val);
d8ce9127 9315 val = ada_to_fixed_value_create (value_type (val), value_address (val), val);
c48db5ca 9316 return val;
14f9c5c9 9317}
d2e4a39e 9318\f
14f9c5c9 9319
14f9c5c9
AS
9320/* Attributes */
9321
4c4b4cd2
PH
9322/* Table mapping attribute numbers to names.
9323 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9324
d2e4a39e 9325static const char *attribute_names[] = {
14f9c5c9
AS
9326 "<?>",
9327
d2e4a39e 9328 "first",
14f9c5c9
AS
9329 "last",
9330 "length",
9331 "image",
14f9c5c9
AS
9332 "max",
9333 "min",
4c4b4cd2
PH
9334 "modulus",
9335 "pos",
9336 "size",
9337 "tag",
14f9c5c9 9338 "val",
14f9c5c9
AS
9339 0
9340};
9341
d2e4a39e 9342const char *
4c4b4cd2 9343ada_attribute_name (enum exp_opcode n)
14f9c5c9 9344{
4c4b4cd2
PH
9345 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9346 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9347 else
9348 return attribute_names[0];
9349}
9350
4c4b4cd2 9351/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9352
4c4b4cd2
PH
9353static LONGEST
9354pos_atr (struct value *arg)
14f9c5c9 9355{
24209737
PH
9356 struct value *val = coerce_ref (arg);
9357 struct type *type = value_type (val);
aa715135 9358 LONGEST result;
14f9c5c9 9359
d2e4a39e 9360 if (!discrete_type_p (type))
323e0a4a 9361 error (_("'POS only defined on discrete types"));
14f9c5c9 9362
aa715135
JG
9363 if (!discrete_position (type, value_as_long (val), &result))
9364 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9365
aa715135 9366 return result;
4c4b4cd2
PH
9367}
9368
9369static struct value *
3cb382c9 9370value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9371{
3cb382c9 9372 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9373}
9374
4c4b4cd2 9375/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9376
d2e4a39e
AS
9377static struct value *
9378value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9379{
d2e4a39e 9380 if (!discrete_type_p (type))
323e0a4a 9381 error (_("'VAL only defined on discrete types"));
df407dfe 9382 if (!integer_type_p (value_type (arg)))
323e0a4a 9383 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9384
9385 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9386 {
9387 long pos = value_as_long (arg);
5b4ee69b 9388
14f9c5c9 9389 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9390 error (_("argument to 'VAL out of range"));
14e75d8e 9391 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9392 }
9393 else
9394 return value_from_longest (type, value_as_long (arg));
9395}
14f9c5c9 9396\f
d2e4a39e 9397
4c4b4cd2 9398 /* Evaluation */
14f9c5c9 9399
4c4b4cd2
PH
9400/* True if TYPE appears to be an Ada character type.
9401 [At the moment, this is true only for Character and Wide_Character;
9402 It is a heuristic test that could stand improvement]. */
14f9c5c9 9403
d2e4a39e
AS
9404int
9405ada_is_character_type (struct type *type)
14f9c5c9 9406{
7b9f71f2
JB
9407 const char *name;
9408
9409 /* If the type code says it's a character, then assume it really is,
9410 and don't check any further. */
9411 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9412 return 1;
9413
9414 /* Otherwise, assume it's a character type iff it is a discrete type
9415 with a known character type name. */
9416 name = ada_type_name (type);
9417 return (name != NULL
9418 && (TYPE_CODE (type) == TYPE_CODE_INT
9419 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9420 && (strcmp (name, "character") == 0
9421 || strcmp (name, "wide_character") == 0
5a517ebd 9422 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9423 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9424}
9425
4c4b4cd2 9426/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9427
9428int
ebf56fd3 9429ada_is_string_type (struct type *type)
14f9c5c9 9430{
61ee279c 9431 type = ada_check_typedef (type);
d2e4a39e 9432 if (type != NULL
14f9c5c9 9433 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9434 && (ada_is_simple_array_type (type)
9435 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9436 && ada_array_arity (type) == 1)
9437 {
9438 struct type *elttype = ada_array_element_type (type, 1);
9439
9440 return ada_is_character_type (elttype);
9441 }
d2e4a39e 9442 else
14f9c5c9
AS
9443 return 0;
9444}
9445
5bf03f13
JB
9446/* The compiler sometimes provides a parallel XVS type for a given
9447 PAD type. Normally, it is safe to follow the PAD type directly,
9448 but older versions of the compiler have a bug that causes the offset
9449 of its "F" field to be wrong. Following that field in that case
9450 would lead to incorrect results, but this can be worked around
9451 by ignoring the PAD type and using the associated XVS type instead.
9452
9453 Set to True if the debugger should trust the contents of PAD types.
9454 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9455static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9456
9457/* True if TYPE is a struct type introduced by the compiler to force the
9458 alignment of a value. Such types have a single field with a
4c4b4cd2 9459 distinctive name. */
14f9c5c9
AS
9460
9461int
ebf56fd3 9462ada_is_aligner_type (struct type *type)
14f9c5c9 9463{
61ee279c 9464 type = ada_check_typedef (type);
714e53ab 9465
5bf03f13 9466 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9467 return 0;
9468
14f9c5c9 9469 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9470 && TYPE_NFIELDS (type) == 1
9471 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9472}
9473
9474/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9475 the parallel type. */
14f9c5c9 9476
d2e4a39e
AS
9477struct type *
9478ada_get_base_type (struct type *raw_type)
14f9c5c9 9479{
d2e4a39e
AS
9480 struct type *real_type_namer;
9481 struct type *raw_real_type;
14f9c5c9
AS
9482
9483 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9484 return raw_type;
9485
284614f0
JB
9486 if (ada_is_aligner_type (raw_type))
9487 /* The encoding specifies that we should always use the aligner type.
9488 So, even if this aligner type has an associated XVS type, we should
9489 simply ignore it.
9490
9491 According to the compiler gurus, an XVS type parallel to an aligner
9492 type may exist because of a stabs limitation. In stabs, aligner
9493 types are empty because the field has a variable-sized type, and
9494 thus cannot actually be used as an aligner type. As a result,
9495 we need the associated parallel XVS type to decode the type.
9496 Since the policy in the compiler is to not change the internal
9497 representation based on the debugging info format, we sometimes
9498 end up having a redundant XVS type parallel to the aligner type. */
9499 return raw_type;
9500
14f9c5c9 9501 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9502 if (real_type_namer == NULL
14f9c5c9
AS
9503 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9504 || TYPE_NFIELDS (real_type_namer) != 1)
9505 return raw_type;
9506
f80d3ff2
JB
9507 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9508 {
9509 /* This is an older encoding form where the base type needs to be
9510 looked up by name. We prefer the newer enconding because it is
9511 more efficient. */
9512 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9513 if (raw_real_type == NULL)
9514 return raw_type;
9515 else
9516 return raw_real_type;
9517 }
9518
9519 /* The field in our XVS type is a reference to the base type. */
9520 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9521}
14f9c5c9 9522
4c4b4cd2 9523/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9524
d2e4a39e
AS
9525struct type *
9526ada_aligned_type (struct type *type)
14f9c5c9
AS
9527{
9528 if (ada_is_aligner_type (type))
9529 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9530 else
9531 return ada_get_base_type (type);
9532}
9533
9534
9535/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9536 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9537
fc1a4b47
AC
9538const gdb_byte *
9539ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9540{
d2e4a39e 9541 if (ada_is_aligner_type (type))
14f9c5c9 9542 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9543 valaddr +
9544 TYPE_FIELD_BITPOS (type,
9545 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9546 else
9547 return valaddr;
9548}
9549
4c4b4cd2
PH
9550
9551
14f9c5c9 9552/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9553 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9554const char *
9555ada_enum_name (const char *name)
14f9c5c9 9556{
4c4b4cd2
PH
9557 static char *result;
9558 static size_t result_len = 0;
e6a959d6 9559 const char *tmp;
14f9c5c9 9560
4c4b4cd2
PH
9561 /* First, unqualify the enumeration name:
9562 1. Search for the last '.' character. If we find one, then skip
177b42fe 9563 all the preceding characters, the unqualified name starts
76a01679 9564 right after that dot.
4c4b4cd2 9565 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9566 translates dots into "__". Search forward for double underscores,
9567 but stop searching when we hit an overloading suffix, which is
9568 of the form "__" followed by digits. */
4c4b4cd2 9569
c3e5cd34
PH
9570 tmp = strrchr (name, '.');
9571 if (tmp != NULL)
4c4b4cd2
PH
9572 name = tmp + 1;
9573 else
14f9c5c9 9574 {
4c4b4cd2
PH
9575 while ((tmp = strstr (name, "__")) != NULL)
9576 {
9577 if (isdigit (tmp[2]))
9578 break;
9579 else
9580 name = tmp + 2;
9581 }
14f9c5c9
AS
9582 }
9583
9584 if (name[0] == 'Q')
9585 {
14f9c5c9 9586 int v;
5b4ee69b 9587
14f9c5c9 9588 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9589 {
9590 if (sscanf (name + 2, "%x", &v) != 1)
9591 return name;
9592 }
14f9c5c9 9593 else
4c4b4cd2 9594 return name;
14f9c5c9 9595
4c4b4cd2 9596 GROW_VECT (result, result_len, 16);
14f9c5c9 9597 if (isascii (v) && isprint (v))
88c15c34 9598 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9599 else if (name[1] == 'U')
88c15c34 9600 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9601 else
88c15c34 9602 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9603
9604 return result;
9605 }
d2e4a39e 9606 else
4c4b4cd2 9607 {
c3e5cd34
PH
9608 tmp = strstr (name, "__");
9609 if (tmp == NULL)
9610 tmp = strstr (name, "$");
9611 if (tmp != NULL)
4c4b4cd2
PH
9612 {
9613 GROW_VECT (result, result_len, tmp - name + 1);
9614 strncpy (result, name, tmp - name);
9615 result[tmp - name] = '\0';
9616 return result;
9617 }
9618
9619 return name;
9620 }
14f9c5c9
AS
9621}
9622
14f9c5c9
AS
9623/* Evaluate the subexpression of EXP starting at *POS as for
9624 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9625 expression. */
14f9c5c9 9626
d2e4a39e
AS
9627static struct value *
9628evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9629{
4b27a620 9630 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9631}
9632
9633/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9634 value it wraps. */
14f9c5c9 9635
d2e4a39e
AS
9636static struct value *
9637unwrap_value (struct value *val)
14f9c5c9 9638{
df407dfe 9639 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9640
14f9c5c9
AS
9641 if (ada_is_aligner_type (type))
9642 {
de4d072f 9643 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9644 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9645
14f9c5c9 9646 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9647 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9648
9649 return unwrap_value (v);
9650 }
d2e4a39e 9651 else
14f9c5c9 9652 {
d2e4a39e 9653 struct type *raw_real_type =
61ee279c 9654 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9655
5bf03f13
JB
9656 /* If there is no parallel XVS or XVE type, then the value is
9657 already unwrapped. Return it without further modification. */
9658 if ((type == raw_real_type)
9659 && ada_find_parallel_type (type, "___XVE") == NULL)
9660 return val;
14f9c5c9 9661
d2e4a39e 9662 return
4c4b4cd2
PH
9663 coerce_unspec_val_to_type
9664 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9665 value_address (val),
1ed6ede0 9666 NULL, 1));
14f9c5c9
AS
9667 }
9668}
d2e4a39e
AS
9669
9670static struct value *
50eff16b 9671cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9672{
50eff16b
UW
9673 struct value *scale = ada_scaling_factor (value_type (arg));
9674 arg = value_cast (value_type (scale), arg);
14f9c5c9 9675
50eff16b
UW
9676 arg = value_binop (arg, scale, BINOP_MUL);
9677 return value_cast (type, arg);
14f9c5c9
AS
9678}
9679
d2e4a39e 9680static struct value *
50eff16b 9681cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9 9682{
50eff16b
UW
9683 if (type == value_type (arg))
9684 return arg;
5b4ee69b 9685
50eff16b
UW
9686 struct value *scale = ada_scaling_factor (type);
9687 if (ada_is_fixed_point_type (value_type (arg)))
9688 arg = cast_from_fixed (value_type (scale), arg);
9689 else
9690 arg = value_cast (value_type (scale), arg);
9691
9692 arg = value_binop (arg, scale, BINOP_DIV);
9693 return value_cast (type, arg);
14f9c5c9
AS
9694}
9695
d99dcf51
JB
9696/* Given two array types T1 and T2, return nonzero iff both arrays
9697 contain the same number of elements. */
9698
9699static int
9700ada_same_array_size_p (struct type *t1, struct type *t2)
9701{
9702 LONGEST lo1, hi1, lo2, hi2;
9703
9704 /* Get the array bounds in order to verify that the size of
9705 the two arrays match. */
9706 if (!get_array_bounds (t1, &lo1, &hi1)
9707 || !get_array_bounds (t2, &lo2, &hi2))
9708 error (_("unable to determine array bounds"));
9709
9710 /* To make things easier for size comparison, normalize a bit
9711 the case of empty arrays by making sure that the difference
9712 between upper bound and lower bound is always -1. */
9713 if (lo1 > hi1)
9714 hi1 = lo1 - 1;
9715 if (lo2 > hi2)
9716 hi2 = lo2 - 1;
9717
9718 return (hi1 - lo1 == hi2 - lo2);
9719}
9720
9721/* Assuming that VAL is an array of integrals, and TYPE represents
9722 an array with the same number of elements, but with wider integral
9723 elements, return an array "casted" to TYPE. In practice, this
9724 means that the returned array is built by casting each element
9725 of the original array into TYPE's (wider) element type. */
9726
9727static struct value *
9728ada_promote_array_of_integrals (struct type *type, struct value *val)
9729{
9730 struct type *elt_type = TYPE_TARGET_TYPE (type);
9731 LONGEST lo, hi;
9732 struct value *res;
9733 LONGEST i;
9734
9735 /* Verify that both val and type are arrays of scalars, and
9736 that the size of val's elements is smaller than the size
9737 of type's element. */
9738 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9739 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9740 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9741 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9742 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9743 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9744
9745 if (!get_array_bounds (type, &lo, &hi))
9746 error (_("unable to determine array bounds"));
9747
9748 res = allocate_value (type);
9749
9750 /* Promote each array element. */
9751 for (i = 0; i < hi - lo + 1; i++)
9752 {
9753 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9754
9755 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9756 value_contents_all (elt), TYPE_LENGTH (elt_type));
9757 }
9758
9759 return res;
9760}
9761
4c4b4cd2
PH
9762/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9763 return the converted value. */
9764
d2e4a39e
AS
9765static struct value *
9766coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9767{
df407dfe 9768 struct type *type2 = value_type (val);
5b4ee69b 9769
14f9c5c9
AS
9770 if (type == type2)
9771 return val;
9772
61ee279c
PH
9773 type2 = ada_check_typedef (type2);
9774 type = ada_check_typedef (type);
14f9c5c9 9775
d2e4a39e
AS
9776 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9777 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9778 {
9779 val = ada_value_ind (val);
df407dfe 9780 type2 = value_type (val);
14f9c5c9
AS
9781 }
9782
d2e4a39e 9783 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9784 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9785 {
d99dcf51
JB
9786 if (!ada_same_array_size_p (type, type2))
9787 error (_("cannot assign arrays of different length"));
9788
9789 if (is_integral_type (TYPE_TARGET_TYPE (type))
9790 && is_integral_type (TYPE_TARGET_TYPE (type2))
9791 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9792 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9793 {
9794 /* Allow implicit promotion of the array elements to
9795 a wider type. */
9796 return ada_promote_array_of_integrals (type, val);
9797 }
9798
9799 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9800 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9801 error (_("Incompatible types in assignment"));
04624583 9802 deprecated_set_value_type (val, type);
14f9c5c9 9803 }
d2e4a39e 9804 return val;
14f9c5c9
AS
9805}
9806
4c4b4cd2
PH
9807static struct value *
9808ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9809{
9810 struct value *val;
9811 struct type *type1, *type2;
9812 LONGEST v, v1, v2;
9813
994b9211
AC
9814 arg1 = coerce_ref (arg1);
9815 arg2 = coerce_ref (arg2);
18af8284
JB
9816 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9817 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9818
76a01679
JB
9819 if (TYPE_CODE (type1) != TYPE_CODE_INT
9820 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9821 return value_binop (arg1, arg2, op);
9822
76a01679 9823 switch (op)
4c4b4cd2
PH
9824 {
9825 case BINOP_MOD:
9826 case BINOP_DIV:
9827 case BINOP_REM:
9828 break;
9829 default:
9830 return value_binop (arg1, arg2, op);
9831 }
9832
9833 v2 = value_as_long (arg2);
9834 if (v2 == 0)
323e0a4a 9835 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9836
9837 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9838 return value_binop (arg1, arg2, op);
9839
9840 v1 = value_as_long (arg1);
9841 switch (op)
9842 {
9843 case BINOP_DIV:
9844 v = v1 / v2;
76a01679
JB
9845 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9846 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9847 break;
9848 case BINOP_REM:
9849 v = v1 % v2;
76a01679
JB
9850 if (v * v1 < 0)
9851 v -= v2;
4c4b4cd2
PH
9852 break;
9853 default:
9854 /* Should not reach this point. */
9855 v = 0;
9856 }
9857
9858 val = allocate_value (type1);
990a07ab 9859 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9860 TYPE_LENGTH (value_type (val)),
9861 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9862 return val;
9863}
9864
9865static int
9866ada_value_equal (struct value *arg1, struct value *arg2)
9867{
df407dfe
AC
9868 if (ada_is_direct_array_type (value_type (arg1))
9869 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9870 {
79e8fcaa
JB
9871 struct type *arg1_type, *arg2_type;
9872
f58b38bf
JB
9873 /* Automatically dereference any array reference before
9874 we attempt to perform the comparison. */
9875 arg1 = ada_coerce_ref (arg1);
9876 arg2 = ada_coerce_ref (arg2);
79e8fcaa 9877
4c4b4cd2
PH
9878 arg1 = ada_coerce_to_simple_array (arg1);
9879 arg2 = ada_coerce_to_simple_array (arg2);
79e8fcaa
JB
9880
9881 arg1_type = ada_check_typedef (value_type (arg1));
9882 arg2_type = ada_check_typedef (value_type (arg2));
9883
9884 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9885 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
323e0a4a 9886 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9887 /* FIXME: The following works only for types whose
76a01679
JB
9888 representations use all bits (no padding or undefined bits)
9889 and do not have user-defined equality. */
79e8fcaa
JB
9890 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9891 && memcmp (value_contents (arg1), value_contents (arg2),
9892 TYPE_LENGTH (arg1_type)) == 0);
4c4b4cd2
PH
9893 }
9894 return value_equal (arg1, arg2);
9895}
9896
52ce6436
PH
9897/* Total number of component associations in the aggregate starting at
9898 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9899 OP_AGGREGATE. */
52ce6436
PH
9900
9901static int
9902num_component_specs (struct expression *exp, int pc)
9903{
9904 int n, m, i;
5b4ee69b 9905
52ce6436
PH
9906 m = exp->elts[pc + 1].longconst;
9907 pc += 3;
9908 n = 0;
9909 for (i = 0; i < m; i += 1)
9910 {
9911 switch (exp->elts[pc].opcode)
9912 {
9913 default:
9914 n += 1;
9915 break;
9916 case OP_CHOICES:
9917 n += exp->elts[pc + 1].longconst;
9918 break;
9919 }
9920 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9921 }
9922 return n;
9923}
9924
9925/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9926 component of LHS (a simple array or a record), updating *POS past
9927 the expression, assuming that LHS is contained in CONTAINER. Does
9928 not modify the inferior's memory, nor does it modify LHS (unless
9929 LHS == CONTAINER). */
9930
9931static void
9932assign_component (struct value *container, struct value *lhs, LONGEST index,
9933 struct expression *exp, int *pos)
9934{
9935 struct value *mark = value_mark ();
9936 struct value *elt;
0e2da9f0 9937 struct type *lhs_type = check_typedef (value_type (lhs));
5b4ee69b 9938
0e2da9f0 9939 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
52ce6436 9940 {
22601c15
UW
9941 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9942 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9943
52ce6436
PH
9944 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9945 }
9946 else
9947 {
9948 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9949 elt = ada_to_fixed_value (elt);
52ce6436
PH
9950 }
9951
9952 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9953 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9954 else
9955 value_assign_to_component (container, elt,
9956 ada_evaluate_subexp (NULL, exp, pos,
9957 EVAL_NORMAL));
9958
9959 value_free_to_mark (mark);
9960}
9961
9962/* Assuming that LHS represents an lvalue having a record or array
9963 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9964 of that aggregate's value to LHS, advancing *POS past the
9965 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9966 lvalue containing LHS (possibly LHS itself). Does not modify
9967 the inferior's memory, nor does it modify the contents of
0963b4bd 9968 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9969
9970static struct value *
9971assign_aggregate (struct value *container,
9972 struct value *lhs, struct expression *exp,
9973 int *pos, enum noside noside)
9974{
9975 struct type *lhs_type;
9976 int n = exp->elts[*pos+1].longconst;
9977 LONGEST low_index, high_index;
9978 int num_specs;
9979 LONGEST *indices;
9980 int max_indices, num_indices;
52ce6436 9981 int i;
52ce6436
PH
9982
9983 *pos += 3;
9984 if (noside != EVAL_NORMAL)
9985 {
52ce6436
PH
9986 for (i = 0; i < n; i += 1)
9987 ada_evaluate_subexp (NULL, exp, pos, noside);
9988 return container;
9989 }
9990
9991 container = ada_coerce_ref (container);
9992 if (ada_is_direct_array_type (value_type (container)))
9993 container = ada_coerce_to_simple_array (container);
9994 lhs = ada_coerce_ref (lhs);
9995 if (!deprecated_value_modifiable (lhs))
9996 error (_("Left operand of assignment is not a modifiable lvalue."));
9997
0e2da9f0 9998 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
9999 if (ada_is_direct_array_type (lhs_type))
10000 {
10001 lhs = ada_coerce_to_simple_array (lhs);
0e2da9f0 10002 lhs_type = check_typedef (value_type (lhs));
52ce6436
PH
10003 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10004 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
10005 }
10006 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10007 {
10008 low_index = 0;
10009 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
10010 }
10011 else
10012 error (_("Left-hand side must be array or record."));
10013
10014 num_specs = num_component_specs (exp, *pos - 3);
10015 max_indices = 4 * num_specs + 4;
8d749320 10016 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
10017 indices[0] = indices[1] = low_index - 1;
10018 indices[2] = indices[3] = high_index + 1;
10019 num_indices = 4;
10020
10021 for (i = 0; i < n; i += 1)
10022 {
10023 switch (exp->elts[*pos].opcode)
10024 {
1fbf5ada
JB
10025 case OP_CHOICES:
10026 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10027 &num_indices, max_indices,
10028 low_index, high_index);
10029 break;
10030 case OP_POSITIONAL:
10031 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
10032 &num_indices, max_indices,
10033 low_index, high_index);
1fbf5ada
JB
10034 break;
10035 case OP_OTHERS:
10036 if (i != n-1)
10037 error (_("Misplaced 'others' clause"));
10038 aggregate_assign_others (container, lhs, exp, pos, indices,
10039 num_indices, low_index, high_index);
10040 break;
10041 default:
10042 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
10043 }
10044 }
10045
10046 return container;
10047}
10048
10049/* Assign into the component of LHS indexed by the OP_POSITIONAL
10050 construct at *POS, updating *POS past the construct, given that
10051 the positions are relative to lower bound LOW, where HIGH is the
10052 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10053 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 10054 assign_aggregate. */
52ce6436
PH
10055static void
10056aggregate_assign_positional (struct value *container,
10057 struct value *lhs, struct expression *exp,
10058 int *pos, LONGEST *indices, int *num_indices,
10059 int max_indices, LONGEST low, LONGEST high)
10060{
10061 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10062
10063 if (ind - 1 == high)
e1d5a0d2 10064 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
10065 if (ind <= high)
10066 {
10067 add_component_interval (ind, ind, indices, num_indices, max_indices);
10068 *pos += 3;
10069 assign_component (container, lhs, ind, exp, pos);
10070 }
10071 else
10072 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10073}
10074
10075/* Assign into the components of LHS indexed by the OP_CHOICES
10076 construct at *POS, updating *POS past the construct, given that
10077 the allowable indices are LOW..HIGH. Record the indices assigned
10078 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 10079 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10080static void
10081aggregate_assign_from_choices (struct value *container,
10082 struct value *lhs, struct expression *exp,
10083 int *pos, LONGEST *indices, int *num_indices,
10084 int max_indices, LONGEST low, LONGEST high)
10085{
10086 int j;
10087 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10088 int choice_pos, expr_pc;
10089 int is_array = ada_is_direct_array_type (value_type (lhs));
10090
10091 choice_pos = *pos += 3;
10092
10093 for (j = 0; j < n_choices; j += 1)
10094 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10095 expr_pc = *pos;
10096 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10097
10098 for (j = 0; j < n_choices; j += 1)
10099 {
10100 LONGEST lower, upper;
10101 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10102
52ce6436
PH
10103 if (op == OP_DISCRETE_RANGE)
10104 {
10105 choice_pos += 1;
10106 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10107 EVAL_NORMAL));
10108 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10109 EVAL_NORMAL));
10110 }
10111 else if (is_array)
10112 {
10113 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10114 EVAL_NORMAL));
10115 upper = lower;
10116 }
10117 else
10118 {
10119 int ind;
0d5cff50 10120 const char *name;
5b4ee69b 10121
52ce6436
PH
10122 switch (op)
10123 {
10124 case OP_NAME:
10125 name = &exp->elts[choice_pos + 2].string;
10126 break;
10127 case OP_VAR_VALUE:
10128 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10129 break;
10130 default:
10131 error (_("Invalid record component association."));
10132 }
10133 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10134 ind = 0;
10135 if (! find_struct_field (name, value_type (lhs), 0,
10136 NULL, NULL, NULL, NULL, &ind))
10137 error (_("Unknown component name: %s."), name);
10138 lower = upper = ind;
10139 }
10140
10141 if (lower <= upper && (lower < low || upper > high))
10142 error (_("Index in component association out of bounds."));
10143
10144 add_component_interval (lower, upper, indices, num_indices,
10145 max_indices);
10146 while (lower <= upper)
10147 {
10148 int pos1;
5b4ee69b 10149
52ce6436
PH
10150 pos1 = expr_pc;
10151 assign_component (container, lhs, lower, exp, &pos1);
10152 lower += 1;
10153 }
10154 }
10155}
10156
10157/* Assign the value of the expression in the OP_OTHERS construct in
10158 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10159 have not been previously assigned. The index intervals already assigned
10160 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10161 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10162static void
10163aggregate_assign_others (struct value *container,
10164 struct value *lhs, struct expression *exp,
10165 int *pos, LONGEST *indices, int num_indices,
10166 LONGEST low, LONGEST high)
10167{
10168 int i;
5ce64950 10169 int expr_pc = *pos + 1;
52ce6436
PH
10170
10171 for (i = 0; i < num_indices - 2; i += 2)
10172 {
10173 LONGEST ind;
5b4ee69b 10174
52ce6436
PH
10175 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10176 {
5ce64950 10177 int localpos;
5b4ee69b 10178
5ce64950
MS
10179 localpos = expr_pc;
10180 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10181 }
10182 }
10183 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10184}
10185
10186/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10187 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10188 modifying *SIZE as needed. It is an error if *SIZE exceeds
10189 MAX_SIZE. The resulting intervals do not overlap. */
10190static void
10191add_component_interval (LONGEST low, LONGEST high,
10192 LONGEST* indices, int *size, int max_size)
10193{
10194 int i, j;
5b4ee69b 10195
52ce6436
PH
10196 for (i = 0; i < *size; i += 2) {
10197 if (high >= indices[i] && low <= indices[i + 1])
10198 {
10199 int kh;
5b4ee69b 10200
52ce6436
PH
10201 for (kh = i + 2; kh < *size; kh += 2)
10202 if (high < indices[kh])
10203 break;
10204 if (low < indices[i])
10205 indices[i] = low;
10206 indices[i + 1] = indices[kh - 1];
10207 if (high > indices[i + 1])
10208 indices[i + 1] = high;
10209 memcpy (indices + i + 2, indices + kh, *size - kh);
10210 *size -= kh - i - 2;
10211 return;
10212 }
10213 else if (high < indices[i])
10214 break;
10215 }
10216
10217 if (*size == max_size)
10218 error (_("Internal error: miscounted aggregate components."));
10219 *size += 2;
10220 for (j = *size-1; j >= i+2; j -= 1)
10221 indices[j] = indices[j - 2];
10222 indices[i] = low;
10223 indices[i + 1] = high;
10224}
10225
6e48bd2c
JB
10226/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10227 is different. */
10228
10229static struct value *
b7e22850 10230ada_value_cast (struct type *type, struct value *arg2)
6e48bd2c
JB
10231{
10232 if (type == ada_check_typedef (value_type (arg2)))
10233 return arg2;
10234
10235 if (ada_is_fixed_point_type (type))
95f39a5b 10236 return cast_to_fixed (type, arg2);
6e48bd2c
JB
10237
10238 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10239 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10240
10241 return value_cast (type, arg2);
10242}
10243
284614f0
JB
10244/* Evaluating Ada expressions, and printing their result.
10245 ------------------------------------------------------
10246
21649b50
JB
10247 1. Introduction:
10248 ----------------
10249
284614f0
JB
10250 We usually evaluate an Ada expression in order to print its value.
10251 We also evaluate an expression in order to print its type, which
10252 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10253 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10254 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10255 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10256 similar.
10257
10258 Evaluating expressions is a little more complicated for Ada entities
10259 than it is for entities in languages such as C. The main reason for
10260 this is that Ada provides types whose definition might be dynamic.
10261 One example of such types is variant records. Or another example
10262 would be an array whose bounds can only be known at run time.
10263
10264 The following description is a general guide as to what should be
10265 done (and what should NOT be done) in order to evaluate an expression
10266 involving such types, and when. This does not cover how the semantic
10267 information is encoded by GNAT as this is covered separatly. For the
10268 document used as the reference for the GNAT encoding, see exp_dbug.ads
10269 in the GNAT sources.
10270
10271 Ideally, we should embed each part of this description next to its
10272 associated code. Unfortunately, the amount of code is so vast right
10273 now that it's hard to see whether the code handling a particular
10274 situation might be duplicated or not. One day, when the code is
10275 cleaned up, this guide might become redundant with the comments
10276 inserted in the code, and we might want to remove it.
10277
21649b50
JB
10278 2. ``Fixing'' an Entity, the Simple Case:
10279 -----------------------------------------
10280
284614f0
JB
10281 When evaluating Ada expressions, the tricky issue is that they may
10282 reference entities whose type contents and size are not statically
10283 known. Consider for instance a variant record:
10284
10285 type Rec (Empty : Boolean := True) is record
10286 case Empty is
10287 when True => null;
10288 when False => Value : Integer;
10289 end case;
10290 end record;
10291 Yes : Rec := (Empty => False, Value => 1);
10292 No : Rec := (empty => True);
10293
10294 The size and contents of that record depends on the value of the
10295 descriminant (Rec.Empty). At this point, neither the debugging
10296 information nor the associated type structure in GDB are able to
10297 express such dynamic types. So what the debugger does is to create
10298 "fixed" versions of the type that applies to the specific object.
10299 We also informally refer to this opperation as "fixing" an object,
10300 which means creating its associated fixed type.
10301
10302 Example: when printing the value of variable "Yes" above, its fixed
10303 type would look like this:
10304
10305 type Rec is record
10306 Empty : Boolean;
10307 Value : Integer;
10308 end record;
10309
10310 On the other hand, if we printed the value of "No", its fixed type
10311 would become:
10312
10313 type Rec is record
10314 Empty : Boolean;
10315 end record;
10316
10317 Things become a little more complicated when trying to fix an entity
10318 with a dynamic type that directly contains another dynamic type,
10319 such as an array of variant records, for instance. There are
10320 two possible cases: Arrays, and records.
10321
21649b50
JB
10322 3. ``Fixing'' Arrays:
10323 ---------------------
10324
10325 The type structure in GDB describes an array in terms of its bounds,
10326 and the type of its elements. By design, all elements in the array
10327 have the same type and we cannot represent an array of variant elements
10328 using the current type structure in GDB. When fixing an array,
10329 we cannot fix the array element, as we would potentially need one
10330 fixed type per element of the array. As a result, the best we can do
10331 when fixing an array is to produce an array whose bounds and size
10332 are correct (allowing us to read it from memory), but without having
10333 touched its element type. Fixing each element will be done later,
10334 when (if) necessary.
10335
10336 Arrays are a little simpler to handle than records, because the same
10337 amount of memory is allocated for each element of the array, even if
1b536f04 10338 the amount of space actually used by each element differs from element
21649b50 10339 to element. Consider for instance the following array of type Rec:
284614f0
JB
10340
10341 type Rec_Array is array (1 .. 2) of Rec;
10342
1b536f04
JB
10343 The actual amount of memory occupied by each element might be different
10344 from element to element, depending on the value of their discriminant.
21649b50 10345 But the amount of space reserved for each element in the array remains
1b536f04 10346 fixed regardless. So we simply need to compute that size using
21649b50
JB
10347 the debugging information available, from which we can then determine
10348 the array size (we multiply the number of elements of the array by
10349 the size of each element).
10350
10351 The simplest case is when we have an array of a constrained element
10352 type. For instance, consider the following type declarations:
10353
10354 type Bounded_String (Max_Size : Integer) is
10355 Length : Integer;
10356 Buffer : String (1 .. Max_Size);
10357 end record;
10358 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10359
10360 In this case, the compiler describes the array as an array of
10361 variable-size elements (identified by its XVS suffix) for which
10362 the size can be read in the parallel XVZ variable.
10363
10364 In the case of an array of an unconstrained element type, the compiler
10365 wraps the array element inside a private PAD type. This type should not
10366 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10367 that we also use the adjective "aligner" in our code to designate
10368 these wrapper types.
10369
1b536f04 10370 In some cases, the size allocated for each element is statically
21649b50
JB
10371 known. In that case, the PAD type already has the correct size,
10372 and the array element should remain unfixed.
10373
10374 But there are cases when this size is not statically known.
10375 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10376
10377 type Dynamic is array (1 .. Five) of Integer;
10378 type Wrapper (Has_Length : Boolean := False) is record
10379 Data : Dynamic;
10380 case Has_Length is
10381 when True => Length : Integer;
10382 when False => null;
10383 end case;
10384 end record;
10385 type Wrapper_Array is array (1 .. 2) of Wrapper;
10386
10387 Hello : Wrapper_Array := (others => (Has_Length => True,
10388 Data => (others => 17),
10389 Length => 1));
10390
10391
10392 The debugging info would describe variable Hello as being an
10393 array of a PAD type. The size of that PAD type is not statically
10394 known, but can be determined using a parallel XVZ variable.
10395 In that case, a copy of the PAD type with the correct size should
10396 be used for the fixed array.
10397
21649b50
JB
10398 3. ``Fixing'' record type objects:
10399 ----------------------------------
10400
10401 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10402 record types. In this case, in order to compute the associated
10403 fixed type, we need to determine the size and offset of each of
10404 its components. This, in turn, requires us to compute the fixed
10405 type of each of these components.
10406
10407 Consider for instance the example:
10408
10409 type Bounded_String (Max_Size : Natural) is record
10410 Str : String (1 .. Max_Size);
10411 Length : Natural;
10412 end record;
10413 My_String : Bounded_String (Max_Size => 10);
10414
10415 In that case, the position of field "Length" depends on the size
10416 of field Str, which itself depends on the value of the Max_Size
21649b50 10417 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10418 we need to fix the type of field Str. Therefore, fixing a variant
10419 record requires us to fix each of its components.
10420
10421 However, if a component does not have a dynamic size, the component
10422 should not be fixed. In particular, fields that use a PAD type
10423 should not fixed. Here is an example where this might happen
10424 (assuming type Rec above):
10425
10426 type Container (Big : Boolean) is record
10427 First : Rec;
10428 After : Integer;
10429 case Big is
10430 when True => Another : Integer;
10431 when False => null;
10432 end case;
10433 end record;
10434 My_Container : Container := (Big => False,
10435 First => (Empty => True),
10436 After => 42);
10437
10438 In that example, the compiler creates a PAD type for component First,
10439 whose size is constant, and then positions the component After just
10440 right after it. The offset of component After is therefore constant
10441 in this case.
10442
10443 The debugger computes the position of each field based on an algorithm
10444 that uses, among other things, the actual position and size of the field
21649b50
JB
10445 preceding it. Let's now imagine that the user is trying to print
10446 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10447 end up computing the offset of field After based on the size of the
10448 fixed version of field First. And since in our example First has
10449 only one actual field, the size of the fixed type is actually smaller
10450 than the amount of space allocated to that field, and thus we would
10451 compute the wrong offset of field After.
10452
21649b50
JB
10453 To make things more complicated, we need to watch out for dynamic
10454 components of variant records (identified by the ___XVL suffix in
10455 the component name). Even if the target type is a PAD type, the size
10456 of that type might not be statically known. So the PAD type needs
10457 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10458 we might end up with the wrong size for our component. This can be
10459 observed with the following type declarations:
284614f0
JB
10460
10461 type Octal is new Integer range 0 .. 7;
10462 type Octal_Array is array (Positive range <>) of Octal;
10463 pragma Pack (Octal_Array);
10464
10465 type Octal_Buffer (Size : Positive) is record
10466 Buffer : Octal_Array (1 .. Size);
10467 Length : Integer;
10468 end record;
10469
10470 In that case, Buffer is a PAD type whose size is unset and needs
10471 to be computed by fixing the unwrapped type.
10472
21649b50
JB
10473 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10474 ----------------------------------------------------------
10475
10476 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10477 thus far, be actually fixed?
10478
10479 The answer is: Only when referencing that element. For instance
10480 when selecting one component of a record, this specific component
10481 should be fixed at that point in time. Or when printing the value
10482 of a record, each component should be fixed before its value gets
10483 printed. Similarly for arrays, the element of the array should be
10484 fixed when printing each element of the array, or when extracting
10485 one element out of that array. On the other hand, fixing should
10486 not be performed on the elements when taking a slice of an array!
10487
31432a67 10488 Note that one of the side effects of miscomputing the offset and
284614f0
JB
10489 size of each field is that we end up also miscomputing the size
10490 of the containing type. This can have adverse results when computing
10491 the value of an entity. GDB fetches the value of an entity based
10492 on the size of its type, and thus a wrong size causes GDB to fetch
10493 the wrong amount of memory. In the case where the computed size is
10494 too small, GDB fetches too little data to print the value of our
31432a67 10495 entity. Results in this case are unpredictable, as we usually read
284614f0
JB
10496 past the buffer containing the data =:-o. */
10497
ced9779b
JB
10498/* Evaluate a subexpression of EXP, at index *POS, and return a value
10499 for that subexpression cast to TO_TYPE. Advance *POS over the
10500 subexpression. */
10501
10502static value *
10503ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10504 enum noside noside, struct type *to_type)
10505{
10506 int pc = *pos;
10507
10508 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10509 || exp->elts[pc].opcode == OP_VAR_VALUE)
10510 {
10511 (*pos) += 4;
10512
10513 value *val;
10514 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10515 {
10516 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10517 return value_zero (to_type, not_lval);
10518
10519 val = evaluate_var_msym_value (noside,
10520 exp->elts[pc + 1].objfile,
10521 exp->elts[pc + 2].msymbol);
10522 }
10523 else
10524 val = evaluate_var_value (noside,
10525 exp->elts[pc + 1].block,
10526 exp->elts[pc + 2].symbol);
10527
10528 if (noside == EVAL_SKIP)
10529 return eval_skip_value (exp);
10530
10531 val = ada_value_cast (to_type, val);
10532
10533 /* Follow the Ada language semantics that do not allow taking
10534 an address of the result of a cast (view conversion in Ada). */
10535 if (VALUE_LVAL (val) == lval_memory)
10536 {
10537 if (value_lazy (val))
10538 value_fetch_lazy (val);
10539 VALUE_LVAL (val) = not_lval;
10540 }
10541 return val;
10542 }
10543
10544 value *val = evaluate_subexp (to_type, exp, pos, noside);
10545 if (noside == EVAL_SKIP)
10546 return eval_skip_value (exp);
10547 return ada_value_cast (to_type, val);
10548}
10549
284614f0
JB
10550/* Implement the evaluate_exp routine in the exp_descriptor structure
10551 for the Ada language. */
10552
52ce6436 10553static struct value *
ebf56fd3 10554ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10555 int *pos, enum noside noside)
14f9c5c9
AS
10556{
10557 enum exp_opcode op;
b5385fc0 10558 int tem;
14f9c5c9 10559 int pc;
5ec18f2b 10560 int preeval_pos;
14f9c5c9
AS
10561 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10562 struct type *type;
52ce6436 10563 int nargs, oplen;
d2e4a39e 10564 struct value **argvec;
14f9c5c9 10565
d2e4a39e
AS
10566 pc = *pos;
10567 *pos += 1;
14f9c5c9
AS
10568 op = exp->elts[pc].opcode;
10569
d2e4a39e 10570 switch (op)
14f9c5c9
AS
10571 {
10572 default:
10573 *pos -= 1;
6e48bd2c 10574 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10575
10576 if (noside == EVAL_NORMAL)
10577 arg1 = unwrap_value (arg1);
6e48bd2c 10578
edd079d9 10579 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
6e48bd2c
JB
10580 then we need to perform the conversion manually, because
10581 evaluate_subexp_standard doesn't do it. This conversion is
10582 necessary in Ada because the different kinds of float/fixed
10583 types in Ada have different representations.
10584
10585 Similarly, we need to perform the conversion from OP_LONG
10586 ourselves. */
edd079d9 10587 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
b7e22850 10588 arg1 = ada_value_cast (expect_type, arg1);
6e48bd2c
JB
10589
10590 return arg1;
4c4b4cd2
PH
10591
10592 case OP_STRING:
10593 {
76a01679 10594 struct value *result;
5b4ee69b 10595
76a01679
JB
10596 *pos -= 1;
10597 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10598 /* The result type will have code OP_STRING, bashed there from
10599 OP_ARRAY. Bash it back. */
df407dfe
AC
10600 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10601 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10602 return result;
4c4b4cd2 10603 }
14f9c5c9
AS
10604
10605 case UNOP_CAST:
10606 (*pos) += 2;
10607 type = exp->elts[pc + 1].type;
ced9779b 10608 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
14f9c5c9 10609
4c4b4cd2
PH
10610 case UNOP_QUAL:
10611 (*pos) += 2;
10612 type = exp->elts[pc + 1].type;
10613 return ada_evaluate_subexp (type, exp, pos, noside);
10614
14f9c5c9
AS
10615 case BINOP_ASSIGN:
10616 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10617 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10618 {
10619 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10620 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10621 return arg1;
10622 return ada_value_assign (arg1, arg1);
10623 }
003f3813
JB
10624 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10625 except if the lhs of our assignment is a convenience variable.
10626 In the case of assigning to a convenience variable, the lhs
10627 should be exactly the result of the evaluation of the rhs. */
10628 type = value_type (arg1);
10629 if (VALUE_LVAL (arg1) == lval_internalvar)
10630 type = NULL;
10631 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10632 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10633 return arg1;
df407dfe
AC
10634 if (ada_is_fixed_point_type (value_type (arg1)))
10635 arg2 = cast_to_fixed (value_type (arg1), arg2);
10636 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10637 error
323e0a4a 10638 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10639 else
df407dfe 10640 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10641 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10642
10643 case BINOP_ADD:
10644 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10645 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10646 if (noside == EVAL_SKIP)
4c4b4cd2 10647 goto nosideret;
2ac8a782
JB
10648 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10649 return (value_from_longest
10650 (value_type (arg1),
10651 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10652 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10653 return (value_from_longest
10654 (value_type (arg2),
10655 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10656 if ((ada_is_fixed_point_type (value_type (arg1))
10657 || ada_is_fixed_point_type (value_type (arg2)))
10658 && value_type (arg1) != value_type (arg2))
323e0a4a 10659 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10660 /* Do the addition, and cast the result to the type of the first
10661 argument. We cannot cast the result to a reference type, so if
10662 ARG1 is a reference type, find its underlying type. */
10663 type = value_type (arg1);
10664 while (TYPE_CODE (type) == TYPE_CODE_REF)
10665 type = TYPE_TARGET_TYPE (type);
f44316fa 10666 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10667 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10668
10669 case BINOP_SUB:
10670 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10671 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10672 if (noside == EVAL_SKIP)
4c4b4cd2 10673 goto nosideret;
2ac8a782
JB
10674 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10675 return (value_from_longest
10676 (value_type (arg1),
10677 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10678 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10679 return (value_from_longest
10680 (value_type (arg2),
10681 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10682 if ((ada_is_fixed_point_type (value_type (arg1))
10683 || ada_is_fixed_point_type (value_type (arg2)))
10684 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10685 error (_("Operands of fixed-point subtraction "
10686 "must have the same type"));
b7789565
JB
10687 /* Do the substraction, and cast the result to the type of the first
10688 argument. We cannot cast the result to a reference type, so if
10689 ARG1 is a reference type, find its underlying type. */
10690 type = value_type (arg1);
10691 while (TYPE_CODE (type) == TYPE_CODE_REF)
10692 type = TYPE_TARGET_TYPE (type);
f44316fa 10693 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10694 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10695
10696 case BINOP_MUL:
10697 case BINOP_DIV:
e1578042
JB
10698 case BINOP_REM:
10699 case BINOP_MOD:
14f9c5c9
AS
10700 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10701 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10702 if (noside == EVAL_SKIP)
4c4b4cd2 10703 goto nosideret;
e1578042 10704 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10705 {
10706 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10707 return value_zero (value_type (arg1), not_lval);
10708 }
14f9c5c9 10709 else
4c4b4cd2 10710 {
a53b7a21 10711 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10712 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10713 arg1 = cast_from_fixed (type, arg1);
df407dfe 10714 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10715 arg2 = cast_from_fixed (type, arg2);
f44316fa 10716 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10717 return ada_value_binop (arg1, arg2, op);
10718 }
10719
4c4b4cd2
PH
10720 case BINOP_EQUAL:
10721 case BINOP_NOTEQUAL:
14f9c5c9 10722 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10723 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10724 if (noside == EVAL_SKIP)
76a01679 10725 goto nosideret;
4c4b4cd2 10726 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10727 tem = 0;
4c4b4cd2 10728 else
f44316fa
UW
10729 {
10730 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10731 tem = ada_value_equal (arg1, arg2);
10732 }
4c4b4cd2 10733 if (op == BINOP_NOTEQUAL)
76a01679 10734 tem = !tem;
fbb06eb1
UW
10735 type = language_bool_type (exp->language_defn, exp->gdbarch);
10736 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10737
10738 case UNOP_NEG:
10739 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10740 if (noside == EVAL_SKIP)
10741 goto nosideret;
df407dfe
AC
10742 else if (ada_is_fixed_point_type (value_type (arg1)))
10743 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10744 else
f44316fa
UW
10745 {
10746 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10747 return value_neg (arg1);
10748 }
4c4b4cd2 10749
2330c6c6
JB
10750 case BINOP_LOGICAL_AND:
10751 case BINOP_LOGICAL_OR:
10752 case UNOP_LOGICAL_NOT:
000d5124
JB
10753 {
10754 struct value *val;
10755
10756 *pos -= 1;
10757 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10758 type = language_bool_type (exp->language_defn, exp->gdbarch);
10759 return value_cast (type, val);
000d5124 10760 }
2330c6c6
JB
10761
10762 case BINOP_BITWISE_AND:
10763 case BINOP_BITWISE_IOR:
10764 case BINOP_BITWISE_XOR:
000d5124
JB
10765 {
10766 struct value *val;
10767
10768 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10769 *pos = pc;
10770 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10771
10772 return value_cast (value_type (arg1), val);
10773 }
2330c6c6 10774
14f9c5c9
AS
10775 case OP_VAR_VALUE:
10776 *pos -= 1;
6799def4 10777
14f9c5c9 10778 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10779 {
10780 *pos += 4;
10781 goto nosideret;
10782 }
da5c522f
JB
10783
10784 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10785 /* Only encountered when an unresolved symbol occurs in a
10786 context other than a function call, in which case, it is
52ce6436 10787 invalid. */
323e0a4a 10788 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10789 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10790
10791 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10792 {
0c1f74cf 10793 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10794 /* Check to see if this is a tagged type. We also need to handle
10795 the case where the type is a reference to a tagged type, but
10796 we have to be careful to exclude pointers to tagged types.
10797 The latter should be shown as usual (as a pointer), whereas
10798 a reference should mostly be transparent to the user. */
10799 if (ada_is_tagged_type (type, 0)
023db19c 10800 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10801 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10802 {
10803 /* Tagged types are a little special in the fact that the real
10804 type is dynamic and can only be determined by inspecting the
10805 object's tag. This means that we need to get the object's
10806 value first (EVAL_NORMAL) and then extract the actual object
10807 type from its tag.
10808
10809 Note that we cannot skip the final step where we extract
10810 the object type from its tag, because the EVAL_NORMAL phase
10811 results in dynamic components being resolved into fixed ones.
10812 This can cause problems when trying to print the type
10813 description of tagged types whose parent has a dynamic size:
10814 We use the type name of the "_parent" component in order
10815 to print the name of the ancestor type in the type description.
10816 If that component had a dynamic size, the resolution into
10817 a fixed type would result in the loss of that type name,
10818 thus preventing us from printing the name of the ancestor
10819 type in the type description. */
10820 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10821
10822 if (TYPE_CODE (type) != TYPE_CODE_REF)
10823 {
10824 struct type *actual_type;
10825
10826 actual_type = type_from_tag (ada_value_tag (arg1));
10827 if (actual_type == NULL)
10828 /* If, for some reason, we were unable to determine
10829 the actual type from the tag, then use the static
10830 approximation that we just computed as a fallback.
10831 This can happen if the debugging information is
10832 incomplete, for instance. */
10833 actual_type = type;
10834 return value_zero (actual_type, not_lval);
10835 }
10836 else
10837 {
10838 /* In the case of a ref, ada_coerce_ref takes care
10839 of determining the actual type. But the evaluation
10840 should return a ref as it should be valid to ask
10841 for its address; so rebuild a ref after coerce. */
10842 arg1 = ada_coerce_ref (arg1);
a65cfae5 10843 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10844 }
10845 }
0c1f74cf 10846
84754697
JB
10847 /* Records and unions for which GNAT encodings have been
10848 generated need to be statically fixed as well.
10849 Otherwise, non-static fixing produces a type where
10850 all dynamic properties are removed, which prevents "ptype"
10851 from being able to completely describe the type.
10852 For instance, a case statement in a variant record would be
10853 replaced by the relevant components based on the actual
10854 value of the discriminants. */
10855 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10856 && dynamic_template_type (type) != NULL)
10857 || (TYPE_CODE (type) == TYPE_CODE_UNION
10858 && ada_find_parallel_type (type, "___XVU") != NULL))
10859 {
10860 *pos += 4;
10861 return value_zero (to_static_fixed_type (type), not_lval);
10862 }
4c4b4cd2 10863 }
da5c522f
JB
10864
10865 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10866 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10867
10868 case OP_FUNCALL:
10869 (*pos) += 2;
10870
10871 /* Allocate arg vector, including space for the function to be
10872 called in argvec[0] and a terminating NULL. */
10873 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10874 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10875
10876 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10877 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10878 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10879 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10880 else
10881 {
10882 for (tem = 0; tem <= nargs; tem += 1)
10883 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10884 argvec[tem] = 0;
10885
10886 if (noside == EVAL_SKIP)
10887 goto nosideret;
10888 }
10889
ad82864c
JB
10890 if (ada_is_constrained_packed_array_type
10891 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10892 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10893 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10894 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10895 /* This is a packed array that has already been fixed, and
10896 therefore already coerced to a simple array. Nothing further
10897 to do. */
10898 ;
e6c2c623
PMR
10899 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10900 {
10901 /* Make sure we dereference references so that all the code below
10902 feels like it's really handling the referenced value. Wrapping
10903 types (for alignment) may be there, so make sure we strip them as
10904 well. */
10905 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10906 }
10907 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10908 && VALUE_LVAL (argvec[0]) == lval_memory)
10909 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10910
df407dfe 10911 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10912
10913 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10914 them. So, if this is an array typedef (encoding use for array
10915 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10916 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10917 type = ada_typedef_target_type (type);
10918
4c4b4cd2
PH
10919 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10920 {
61ee279c 10921 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10922 {
10923 case TYPE_CODE_FUNC:
61ee279c 10924 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10925 break;
10926 case TYPE_CODE_ARRAY:
10927 break;
10928 case TYPE_CODE_STRUCT:
10929 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10930 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10931 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10932 break;
10933 default:
323e0a4a 10934 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10935 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10936 break;
10937 }
10938 }
10939
10940 switch (TYPE_CODE (type))
10941 {
10942 case TYPE_CODE_FUNC:
10943 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10944 {
7022349d
PA
10945 if (TYPE_TARGET_TYPE (type) == NULL)
10946 error_call_unknown_return_type (NULL);
10947 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10948 }
7022349d 10949 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
c8ea1972
PH
10950 case TYPE_CODE_INTERNAL_FUNCTION:
10951 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10952 /* We don't know anything about what the internal
10953 function might return, but we have to return
10954 something. */
10955 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10956 not_lval);
10957 else
10958 return call_internal_function (exp->gdbarch, exp->language_defn,
10959 argvec[0], nargs, argvec + 1);
10960
4c4b4cd2
PH
10961 case TYPE_CODE_STRUCT:
10962 {
10963 int arity;
10964
4c4b4cd2
PH
10965 arity = ada_array_arity (type);
10966 type = ada_array_element_type (type, nargs);
10967 if (type == NULL)
323e0a4a 10968 error (_("cannot subscript or call a record"));
4c4b4cd2 10969 if (arity != nargs)
323e0a4a 10970 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10971 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10972 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10973 return
10974 unwrap_value (ada_value_subscript
10975 (argvec[0], nargs, argvec + 1));
10976 }
10977 case TYPE_CODE_ARRAY:
10978 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10979 {
10980 type = ada_array_element_type (type, nargs);
10981 if (type == NULL)
323e0a4a 10982 error (_("element type of array unknown"));
4c4b4cd2 10983 else
0a07e705 10984 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10985 }
10986 return
10987 unwrap_value (ada_value_subscript
10988 (ada_coerce_to_simple_array (argvec[0]),
10989 nargs, argvec + 1));
10990 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10991 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10992 {
deede10c 10993 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10994 type = ada_array_element_type (type, nargs);
10995 if (type == NULL)
323e0a4a 10996 error (_("element type of array unknown"));
4c4b4cd2 10997 else
0a07e705 10998 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10999 }
11000 return
deede10c
JB
11001 unwrap_value (ada_value_ptr_subscript (argvec[0],
11002 nargs, argvec + 1));
4c4b4cd2
PH
11003
11004 default:
e1d5a0d2
PH
11005 error (_("Attempt to index or call something other than an "
11006 "array or function"));
4c4b4cd2
PH
11007 }
11008
11009 case TERNOP_SLICE:
11010 {
11011 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11012 struct value *low_bound_val =
11013 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
11014 struct value *high_bound_val =
11015 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11016 LONGEST low_bound;
11017 LONGEST high_bound;
5b4ee69b 11018
994b9211
AC
11019 low_bound_val = coerce_ref (low_bound_val);
11020 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
11021 low_bound = value_as_long (low_bound_val);
11022 high_bound = value_as_long (high_bound_val);
963a6417 11023
4c4b4cd2
PH
11024 if (noside == EVAL_SKIP)
11025 goto nosideret;
11026
4c4b4cd2
PH
11027 /* If this is a reference to an aligner type, then remove all
11028 the aligners. */
df407dfe
AC
11029 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11030 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11031 TYPE_TARGET_TYPE (value_type (array)) =
11032 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 11033
ad82864c 11034 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 11035 error (_("cannot slice a packed array"));
4c4b4cd2
PH
11036
11037 /* If this is a reference to an array or an array lvalue,
11038 convert to a pointer. */
df407dfe
AC
11039 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11040 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
11041 && VALUE_LVAL (array) == lval_memory))
11042 array = value_addr (array);
11043
1265e4aa 11044 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 11045 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 11046 (value_type (array))))
0b5d8877 11047 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
11048
11049 array = ada_coerce_to_simple_array_ptr (array);
11050
714e53ab
PH
11051 /* If we have more than one level of pointer indirection,
11052 dereference the value until we get only one level. */
df407dfe
AC
11053 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11054 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
11055 == TYPE_CODE_PTR))
11056 array = value_ind (array);
11057
11058 /* Make sure we really do have an array type before going further,
11059 to avoid a SEGV when trying to get the index type or the target
11060 type later down the road if the debug info generated by
11061 the compiler is incorrect or incomplete. */
df407dfe 11062 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 11063 error (_("cannot take slice of non-array"));
714e53ab 11064
828292f2
JB
11065 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11066 == TYPE_CODE_PTR)
4c4b4cd2 11067 {
828292f2
JB
11068 struct type *type0 = ada_check_typedef (value_type (array));
11069
0b5d8877 11070 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 11071 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
11072 else
11073 {
11074 struct type *arr_type0 =
828292f2 11075 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 11076
f5938064
JG
11077 return ada_value_slice_from_ptr (array, arr_type0,
11078 longest_to_int (low_bound),
11079 longest_to_int (high_bound));
4c4b4cd2
PH
11080 }
11081 }
11082 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11083 return array;
11084 else if (high_bound < low_bound)
df407dfe 11085 return empty_array (value_type (array), low_bound);
4c4b4cd2 11086 else
529cad9c
PH
11087 return ada_value_slice (array, longest_to_int (low_bound),
11088 longest_to_int (high_bound));
4c4b4cd2 11089 }
14f9c5c9 11090
4c4b4cd2
PH
11091 case UNOP_IN_RANGE:
11092 (*pos) += 2;
11093 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 11094 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 11095
14f9c5c9 11096 if (noside == EVAL_SKIP)
4c4b4cd2 11097 goto nosideret;
14f9c5c9 11098
4c4b4cd2
PH
11099 switch (TYPE_CODE (type))
11100 {
11101 default:
e1d5a0d2
PH
11102 lim_warning (_("Membership test incompletely implemented; "
11103 "always returns true"));
fbb06eb1
UW
11104 type = language_bool_type (exp->language_defn, exp->gdbarch);
11105 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
11106
11107 case TYPE_CODE_RANGE:
030b4912
UW
11108 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11109 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
11110 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11111 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
11112 type = language_bool_type (exp->language_defn, exp->gdbarch);
11113 return
11114 value_from_longest (type,
4c4b4cd2
PH
11115 (value_less (arg1, arg3)
11116 || value_equal (arg1, arg3))
11117 && (value_less (arg2, arg1)
11118 || value_equal (arg2, arg1)));
11119 }
11120
11121 case BINOP_IN_BOUNDS:
14f9c5c9 11122 (*pos) += 2;
4c4b4cd2
PH
11123 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11124 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11125
4c4b4cd2
PH
11126 if (noside == EVAL_SKIP)
11127 goto nosideret;
14f9c5c9 11128
4c4b4cd2 11129 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
11130 {
11131 type = language_bool_type (exp->language_defn, exp->gdbarch);
11132 return value_zero (type, not_lval);
11133 }
14f9c5c9 11134
4c4b4cd2 11135 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11136
1eea4ebd
UW
11137 type = ada_index_type (value_type (arg2), tem, "range");
11138 if (!type)
11139 type = value_type (arg1);
14f9c5c9 11140
1eea4ebd
UW
11141 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11142 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 11143
f44316fa
UW
11144 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11145 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11146 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11147 return
fbb06eb1 11148 value_from_longest (type,
4c4b4cd2
PH
11149 (value_less (arg1, arg3)
11150 || value_equal (arg1, arg3))
11151 && (value_less (arg2, arg1)
11152 || value_equal (arg2, arg1)));
11153
11154 case TERNOP_IN_RANGE:
11155 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11156 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11157 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11158
11159 if (noside == EVAL_SKIP)
11160 goto nosideret;
11161
f44316fa
UW
11162 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11163 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11164 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11165 return
fbb06eb1 11166 value_from_longest (type,
4c4b4cd2
PH
11167 (value_less (arg1, arg3)
11168 || value_equal (arg1, arg3))
11169 && (value_less (arg2, arg1)
11170 || value_equal (arg2, arg1)));
11171
11172 case OP_ATR_FIRST:
11173 case OP_ATR_LAST:
11174 case OP_ATR_LENGTH:
11175 {
76a01679 11176 struct type *type_arg;
5b4ee69b 11177
76a01679
JB
11178 if (exp->elts[*pos].opcode == OP_TYPE)
11179 {
11180 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11181 arg1 = NULL;
5bc23cb3 11182 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11183 }
11184 else
11185 {
11186 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11187 type_arg = NULL;
11188 }
11189
11190 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11191 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11192 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11193 *pos += 4;
11194
11195 if (noside == EVAL_SKIP)
11196 goto nosideret;
11197
11198 if (type_arg == NULL)
11199 {
11200 arg1 = ada_coerce_ref (arg1);
11201
ad82864c 11202 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11203 arg1 = ada_coerce_to_simple_array (arg1);
11204
aa4fb036 11205 if (op == OP_ATR_LENGTH)
1eea4ebd 11206 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11207 else
11208 {
11209 type = ada_index_type (value_type (arg1), tem,
11210 ada_attribute_name (op));
11211 if (type == NULL)
11212 type = builtin_type (exp->gdbarch)->builtin_int;
11213 }
76a01679
JB
11214
11215 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11216 return allocate_value (type);
76a01679
JB
11217
11218 switch (op)
11219 {
11220 default: /* Should never happen. */
323e0a4a 11221 error (_("unexpected attribute encountered"));
76a01679 11222 case OP_ATR_FIRST:
1eea4ebd
UW
11223 return value_from_longest
11224 (type, ada_array_bound (arg1, tem, 0));
76a01679 11225 case OP_ATR_LAST:
1eea4ebd
UW
11226 return value_from_longest
11227 (type, ada_array_bound (arg1, tem, 1));
76a01679 11228 case OP_ATR_LENGTH:
1eea4ebd
UW
11229 return value_from_longest
11230 (type, ada_array_length (arg1, tem));
76a01679
JB
11231 }
11232 }
11233 else if (discrete_type_p (type_arg))
11234 {
11235 struct type *range_type;
0d5cff50 11236 const char *name = ada_type_name (type_arg);
5b4ee69b 11237
76a01679
JB
11238 range_type = NULL;
11239 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11240 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11241 if (range_type == NULL)
11242 range_type = type_arg;
11243 switch (op)
11244 {
11245 default:
323e0a4a 11246 error (_("unexpected attribute encountered"));
76a01679 11247 case OP_ATR_FIRST:
690cc4eb 11248 return value_from_longest
43bbcdc2 11249 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11250 case OP_ATR_LAST:
690cc4eb 11251 return value_from_longest
43bbcdc2 11252 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11253 case OP_ATR_LENGTH:
323e0a4a 11254 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11255 }
11256 }
11257 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11258 error (_("unimplemented type attribute"));
76a01679
JB
11259 else
11260 {
11261 LONGEST low, high;
11262
ad82864c
JB
11263 if (ada_is_constrained_packed_array_type (type_arg))
11264 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11265
aa4fb036 11266 if (op == OP_ATR_LENGTH)
1eea4ebd 11267 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11268 else
11269 {
11270 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11271 if (type == NULL)
11272 type = builtin_type (exp->gdbarch)->builtin_int;
11273 }
1eea4ebd 11274
76a01679
JB
11275 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11276 return allocate_value (type);
11277
11278 switch (op)
11279 {
11280 default:
323e0a4a 11281 error (_("unexpected attribute encountered"));
76a01679 11282 case OP_ATR_FIRST:
1eea4ebd 11283 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11284 return value_from_longest (type, low);
11285 case OP_ATR_LAST:
1eea4ebd 11286 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11287 return value_from_longest (type, high);
11288 case OP_ATR_LENGTH:
1eea4ebd
UW
11289 low = ada_array_bound_from_type (type_arg, tem, 0);
11290 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11291 return value_from_longest (type, high - low + 1);
11292 }
11293 }
14f9c5c9
AS
11294 }
11295
4c4b4cd2
PH
11296 case OP_ATR_TAG:
11297 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11298 if (noside == EVAL_SKIP)
76a01679 11299 goto nosideret;
4c4b4cd2
PH
11300
11301 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11302 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11303
11304 return ada_value_tag (arg1);
11305
11306 case OP_ATR_MIN:
11307 case OP_ATR_MAX:
11308 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11309 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11310 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11311 if (noside == EVAL_SKIP)
76a01679 11312 goto nosideret;
d2e4a39e 11313 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11314 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11315 else
f44316fa
UW
11316 {
11317 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11318 return value_binop (arg1, arg2,
11319 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11320 }
14f9c5c9 11321
4c4b4cd2
PH
11322 case OP_ATR_MODULUS:
11323 {
31dedfee 11324 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11325
5b4ee69b 11326 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11327 if (noside == EVAL_SKIP)
11328 goto nosideret;
4c4b4cd2 11329
76a01679 11330 if (!ada_is_modular_type (type_arg))
323e0a4a 11331 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11332
76a01679
JB
11333 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11334 ada_modulus (type_arg));
4c4b4cd2
PH
11335 }
11336
11337
11338 case OP_ATR_POS:
11339 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11340 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11341 if (noside == EVAL_SKIP)
76a01679 11342 goto nosideret;
3cb382c9
UW
11343 type = builtin_type (exp->gdbarch)->builtin_int;
11344 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11345 return value_zero (type, not_lval);
14f9c5c9 11346 else
3cb382c9 11347 return value_pos_atr (type, arg1);
14f9c5c9 11348
4c4b4cd2
PH
11349 case OP_ATR_SIZE:
11350 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11351 type = value_type (arg1);
11352
11353 /* If the argument is a reference, then dereference its type, since
11354 the user is really asking for the size of the actual object,
11355 not the size of the pointer. */
11356 if (TYPE_CODE (type) == TYPE_CODE_REF)
11357 type = TYPE_TARGET_TYPE (type);
11358
4c4b4cd2 11359 if (noside == EVAL_SKIP)
76a01679 11360 goto nosideret;
4c4b4cd2 11361 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11362 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11363 else
22601c15 11364 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11365 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11366
11367 case OP_ATR_VAL:
11368 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11369 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11370 type = exp->elts[pc + 2].type;
14f9c5c9 11371 if (noside == EVAL_SKIP)
76a01679 11372 goto nosideret;
4c4b4cd2 11373 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11374 return value_zero (type, not_lval);
4c4b4cd2 11375 else
76a01679 11376 return value_val_atr (type, arg1);
4c4b4cd2
PH
11377
11378 case BINOP_EXP:
11379 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11380 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11381 if (noside == EVAL_SKIP)
11382 goto nosideret;
11383 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11384 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11385 else
f44316fa
UW
11386 {
11387 /* For integer exponentiation operations,
11388 only promote the first argument. */
11389 if (is_integral_type (value_type (arg2)))
11390 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11391 else
11392 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11393
11394 return value_binop (arg1, arg2, op);
11395 }
4c4b4cd2
PH
11396
11397 case UNOP_PLUS:
11398 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11399 if (noside == EVAL_SKIP)
11400 goto nosideret;
11401 else
11402 return arg1;
11403
11404 case UNOP_ABS:
11405 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11406 if (noside == EVAL_SKIP)
11407 goto nosideret;
f44316fa 11408 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11409 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11410 return value_neg (arg1);
14f9c5c9 11411 else
4c4b4cd2 11412 return arg1;
14f9c5c9
AS
11413
11414 case UNOP_IND:
5ec18f2b 11415 preeval_pos = *pos;
6b0d7253 11416 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11417 if (noside == EVAL_SKIP)
4c4b4cd2 11418 goto nosideret;
df407dfe 11419 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11420 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11421 {
11422 if (ada_is_array_descriptor_type (type))
11423 /* GDB allows dereferencing GNAT array descriptors. */
11424 {
11425 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11426
4c4b4cd2 11427 if (arrType == NULL)
323e0a4a 11428 error (_("Attempt to dereference null array pointer."));
00a4c844 11429 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11430 }
11431 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11432 || TYPE_CODE (type) == TYPE_CODE_REF
11433 /* In C you can dereference an array to get the 1st elt. */
11434 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11435 {
5ec18f2b
JG
11436 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11437 only be determined by inspecting the object's tag.
11438 This means that we need to evaluate completely the
11439 expression in order to get its type. */
11440
023db19c
JB
11441 if ((TYPE_CODE (type) == TYPE_CODE_REF
11442 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11443 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11444 {
11445 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11446 EVAL_NORMAL);
11447 type = value_type (ada_value_ind (arg1));
11448 }
11449 else
11450 {
11451 type = to_static_fixed_type
11452 (ada_aligned_type
11453 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11454 }
c1b5a1a6 11455 ada_ensure_varsize_limit (type);
714e53ab
PH
11456 return value_zero (type, lval_memory);
11457 }
4c4b4cd2 11458 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11459 {
11460 /* GDB allows dereferencing an int. */
11461 if (expect_type == NULL)
11462 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11463 lval_memory);
11464 else
11465 {
11466 expect_type =
11467 to_static_fixed_type (ada_aligned_type (expect_type));
11468 return value_zero (expect_type, lval_memory);
11469 }
11470 }
4c4b4cd2 11471 else
323e0a4a 11472 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11473 }
0963b4bd 11474 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11475 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11476
96967637
JB
11477 if (TYPE_CODE (type) == TYPE_CODE_INT)
11478 /* GDB allows dereferencing an int. If we were given
11479 the expect_type, then use that as the target type.
11480 Otherwise, assume that the target type is an int. */
11481 {
11482 if (expect_type != NULL)
11483 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11484 arg1));
11485 else
11486 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11487 (CORE_ADDR) value_as_address (arg1));
11488 }
6b0d7253 11489
4c4b4cd2
PH
11490 if (ada_is_array_descriptor_type (type))
11491 /* GDB allows dereferencing GNAT array descriptors. */
11492 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11493 else
4c4b4cd2 11494 return ada_value_ind (arg1);
14f9c5c9
AS
11495
11496 case STRUCTOP_STRUCT:
11497 tem = longest_to_int (exp->elts[pc + 1].longconst);
11498 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11499 preeval_pos = *pos;
14f9c5c9
AS
11500 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11501 if (noside == EVAL_SKIP)
4c4b4cd2 11502 goto nosideret;
14f9c5c9 11503 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11504 {
df407dfe 11505 struct type *type1 = value_type (arg1);
5b4ee69b 11506
76a01679
JB
11507 if (ada_is_tagged_type (type1, 1))
11508 {
11509 type = ada_lookup_struct_elt_type (type1,
11510 &exp->elts[pc + 2].string,
988f6b3d 11511 1, 1);
5ec18f2b
JG
11512
11513 /* If the field is not found, check if it exists in the
11514 extension of this object's type. This means that we
11515 need to evaluate completely the expression. */
11516
76a01679 11517 if (type == NULL)
5ec18f2b
JG
11518 {
11519 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11520 EVAL_NORMAL);
11521 arg1 = ada_value_struct_elt (arg1,
11522 &exp->elts[pc + 2].string,
11523 0);
11524 arg1 = unwrap_value (arg1);
11525 type = value_type (ada_to_fixed_value (arg1));
11526 }
76a01679
JB
11527 }
11528 else
11529 type =
11530 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11531 0);
76a01679
JB
11532
11533 return value_zero (ada_aligned_type (type), lval_memory);
11534 }
14f9c5c9 11535 else
a579cd9a
MW
11536 {
11537 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11538 arg1 = unwrap_value (arg1);
11539 return ada_to_fixed_value (arg1);
11540 }
284614f0 11541
14f9c5c9 11542 case OP_TYPE:
4c4b4cd2
PH
11543 /* The value is not supposed to be used. This is here to make it
11544 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11545 (*pos) += 2;
11546 if (noside == EVAL_SKIP)
4c4b4cd2 11547 goto nosideret;
14f9c5c9 11548 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11549 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11550 else
323e0a4a 11551 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11552
11553 case OP_AGGREGATE:
11554 case OP_CHOICES:
11555 case OP_OTHERS:
11556 case OP_DISCRETE_RANGE:
11557 case OP_POSITIONAL:
11558 case OP_NAME:
11559 if (noside == EVAL_NORMAL)
11560 switch (op)
11561 {
11562 case OP_NAME:
11563 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11564 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11565 case OP_AGGREGATE:
11566 error (_("Aggregates only allowed on the right of an assignment"));
11567 default:
0963b4bd
MS
11568 internal_error (__FILE__, __LINE__,
11569 _("aggregate apparently mangled"));
52ce6436
PH
11570 }
11571
11572 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11573 *pos += oplen - 1;
11574 for (tem = 0; tem < nargs; tem += 1)
11575 ada_evaluate_subexp (NULL, exp, pos, noside);
11576 goto nosideret;
14f9c5c9
AS
11577 }
11578
11579nosideret:
ced9779b 11580 return eval_skip_value (exp);
14f9c5c9 11581}
14f9c5c9 11582\f
d2e4a39e 11583
4c4b4cd2 11584 /* Fixed point */
14f9c5c9
AS
11585
11586/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11587 type name that encodes the 'small and 'delta information.
4c4b4cd2 11588 Otherwise, return NULL. */
14f9c5c9 11589
d2e4a39e 11590static const char *
ebf56fd3 11591fixed_type_info (struct type *type)
14f9c5c9 11592{
d2e4a39e 11593 const char *name = ada_type_name (type);
14f9c5c9
AS
11594 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11595
d2e4a39e
AS
11596 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11597 {
14f9c5c9 11598 const char *tail = strstr (name, "___XF_");
5b4ee69b 11599
14f9c5c9 11600 if (tail == NULL)
4c4b4cd2 11601 return NULL;
d2e4a39e 11602 else
4c4b4cd2 11603 return tail + 5;
14f9c5c9
AS
11604 }
11605 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11606 return fixed_type_info (TYPE_TARGET_TYPE (type));
11607 else
11608 return NULL;
11609}
11610
4c4b4cd2 11611/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11612
11613int
ebf56fd3 11614ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11615{
11616 return fixed_type_info (type) != NULL;
11617}
11618
4c4b4cd2
PH
11619/* Return non-zero iff TYPE represents a System.Address type. */
11620
11621int
11622ada_is_system_address_type (struct type *type)
11623{
11624 return (TYPE_NAME (type)
11625 && strcmp (TYPE_NAME (type), "system__address") == 0);
11626}
11627
14f9c5c9 11628/* Assuming that TYPE is the representation of an Ada fixed-point
50eff16b
UW
11629 type, return the target floating-point type to be used to represent
11630 of this type during internal computation. */
11631
11632static struct type *
11633ada_scaling_type (struct type *type)
11634{
11635 return builtin_type (get_type_arch (type))->builtin_long_double;
11636}
11637
11638/* Assuming that TYPE is the representation of an Ada fixed-point
11639 type, return its delta, or NULL if the type is malformed and the
4c4b4cd2 11640 delta cannot be determined. */
14f9c5c9 11641
50eff16b 11642struct value *
ebf56fd3 11643ada_delta (struct type *type)
14f9c5c9
AS
11644{
11645 const char *encoding = fixed_type_info (type);
50eff16b
UW
11646 struct type *scale_type = ada_scaling_type (type);
11647
11648 long long num, den;
11649
11650 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11651 return nullptr;
d2e4a39e 11652 else
50eff16b
UW
11653 return value_binop (value_from_longest (scale_type, num),
11654 value_from_longest (scale_type, den), BINOP_DIV);
14f9c5c9
AS
11655}
11656
11657/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11658 factor ('SMALL value) associated with the type. */
14f9c5c9 11659
50eff16b
UW
11660struct value *
11661ada_scaling_factor (struct type *type)
14f9c5c9
AS
11662{
11663 const char *encoding = fixed_type_info (type);
50eff16b
UW
11664 struct type *scale_type = ada_scaling_type (type);
11665
11666 long long num0, den0, num1, den1;
14f9c5c9 11667 int n;
d2e4a39e 11668
50eff16b 11669 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
facc390f 11670 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11671
11672 if (n < 2)
50eff16b 11673 return value_from_longest (scale_type, 1);
14f9c5c9 11674 else if (n == 4)
50eff16b
UW
11675 return value_binop (value_from_longest (scale_type, num1),
11676 value_from_longest (scale_type, den1), BINOP_DIV);
d2e4a39e 11677 else
50eff16b
UW
11678 return value_binop (value_from_longest (scale_type, num0),
11679 value_from_longest (scale_type, den0), BINOP_DIV);
14f9c5c9
AS
11680}
11681
14f9c5c9 11682\f
d2e4a39e 11683
4c4b4cd2 11684 /* Range types */
14f9c5c9
AS
11685
11686/* Scan STR beginning at position K for a discriminant name, and
11687 return the value of that discriminant field of DVAL in *PX. If
11688 PNEW_K is not null, put the position of the character beyond the
11689 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11690 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11691
11692static int
108d56a4 11693scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11694 int *pnew_k)
14f9c5c9
AS
11695{
11696 static char *bound_buffer = NULL;
11697 static size_t bound_buffer_len = 0;
5da1a4d3 11698 const char *pstart, *pend, *bound;
d2e4a39e 11699 struct value *bound_val;
14f9c5c9
AS
11700
11701 if (dval == NULL || str == NULL || str[k] == '\0')
11702 return 0;
11703
5da1a4d3
SM
11704 pstart = str + k;
11705 pend = strstr (pstart, "__");
14f9c5c9
AS
11706 if (pend == NULL)
11707 {
5da1a4d3 11708 bound = pstart;
14f9c5c9
AS
11709 k += strlen (bound);
11710 }
d2e4a39e 11711 else
14f9c5c9 11712 {
5da1a4d3
SM
11713 int len = pend - pstart;
11714
11715 /* Strip __ and beyond. */
11716 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11717 strncpy (bound_buffer, pstart, len);
11718 bound_buffer[len] = '\0';
11719
14f9c5c9 11720 bound = bound_buffer;
d2e4a39e 11721 k = pend - str;
14f9c5c9 11722 }
d2e4a39e 11723
df407dfe 11724 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11725 if (bound_val == NULL)
11726 return 0;
11727
11728 *px = value_as_long (bound_val);
11729 if (pnew_k != NULL)
11730 *pnew_k = k;
11731 return 1;
11732}
11733
11734/* Value of variable named NAME in the current environment. If
11735 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11736 otherwise causes an error with message ERR_MSG. */
11737
d2e4a39e 11738static struct value *
edb0c9cb 11739get_var_value (const char *name, const char *err_msg)
14f9c5c9 11740{
b5ec771e 11741 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
14f9c5c9 11742
54d343a2 11743 std::vector<struct block_symbol> syms;
b5ec771e
PA
11744 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11745 get_selected_block (0),
11746 VAR_DOMAIN, &syms, 1);
14f9c5c9
AS
11747
11748 if (nsyms != 1)
11749 {
11750 if (err_msg == NULL)
4c4b4cd2 11751 return 0;
14f9c5c9 11752 else
8a3fe4f8 11753 error (("%s"), err_msg);
14f9c5c9
AS
11754 }
11755
54d343a2 11756 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11757}
d2e4a39e 11758
edb0c9cb
PA
11759/* Value of integer variable named NAME in the current environment.
11760 If no such variable is found, returns false. Otherwise, sets VALUE
11761 to the variable's value and returns true. */
4c4b4cd2 11762
edb0c9cb
PA
11763bool
11764get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11765{
4c4b4cd2 11766 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11767
14f9c5c9 11768 if (var_val == 0)
edb0c9cb
PA
11769 return false;
11770
11771 value = value_as_long (var_val);
11772 return true;
14f9c5c9 11773}
d2e4a39e 11774
14f9c5c9
AS
11775
11776/* Return a range type whose base type is that of the range type named
11777 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11778 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11779 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11780 corresponding range type from debug information; fall back to using it
11781 if symbol lookup fails. If a new type must be created, allocate it
11782 like ORIG_TYPE was. The bounds information, in general, is encoded
11783 in NAME, the base type given in the named range type. */
14f9c5c9 11784
d2e4a39e 11785static struct type *
28c85d6c 11786to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11787{
0d5cff50 11788 const char *name;
14f9c5c9 11789 struct type *base_type;
108d56a4 11790 const char *subtype_info;
14f9c5c9 11791
28c85d6c
JB
11792 gdb_assert (raw_type != NULL);
11793 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11794
1ce677a4 11795 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11796 base_type = TYPE_TARGET_TYPE (raw_type);
11797 else
11798 base_type = raw_type;
11799
28c85d6c 11800 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11801 subtype_info = strstr (name, "___XD");
11802 if (subtype_info == NULL)
690cc4eb 11803 {
43bbcdc2
PH
11804 LONGEST L = ada_discrete_type_low_bound (raw_type);
11805 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11806
690cc4eb
PH
11807 if (L < INT_MIN || U > INT_MAX)
11808 return raw_type;
11809 else
0c9c3474
SA
11810 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11811 L, U);
690cc4eb 11812 }
14f9c5c9
AS
11813 else
11814 {
11815 static char *name_buf = NULL;
11816 static size_t name_len = 0;
11817 int prefix_len = subtype_info - name;
11818 LONGEST L, U;
11819 struct type *type;
108d56a4 11820 const char *bounds_str;
14f9c5c9
AS
11821 int n;
11822
11823 GROW_VECT (name_buf, name_len, prefix_len + 5);
11824 strncpy (name_buf, name, prefix_len);
11825 name_buf[prefix_len] = '\0';
11826
11827 subtype_info += 5;
11828 bounds_str = strchr (subtype_info, '_');
11829 n = 1;
11830
d2e4a39e 11831 if (*subtype_info == 'L')
4c4b4cd2
PH
11832 {
11833 if (!ada_scan_number (bounds_str, n, &L, &n)
11834 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11835 return raw_type;
11836 if (bounds_str[n] == '_')
11837 n += 2;
0963b4bd 11838 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11839 n += 1;
11840 subtype_info += 1;
11841 }
d2e4a39e 11842 else
4c4b4cd2 11843 {
4c4b4cd2 11844 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11845 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11846 {
323e0a4a 11847 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11848 L = 1;
11849 }
11850 }
14f9c5c9 11851
d2e4a39e 11852 if (*subtype_info == 'U')
4c4b4cd2
PH
11853 {
11854 if (!ada_scan_number (bounds_str, n, &U, &n)
11855 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11856 return raw_type;
11857 }
d2e4a39e 11858 else
4c4b4cd2 11859 {
4c4b4cd2 11860 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11861 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11862 {
323e0a4a 11863 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11864 U = L;
11865 }
11866 }
14f9c5c9 11867
0c9c3474
SA
11868 type = create_static_range_type (alloc_type_copy (raw_type),
11869 base_type, L, U);
f5a91472
JB
11870 /* create_static_range_type alters the resulting type's length
11871 to match the size of the base_type, which is not what we want.
11872 Set it back to the original range type's length. */
11873 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
d2e4a39e 11874 TYPE_NAME (type) = name;
14f9c5c9
AS
11875 return type;
11876 }
11877}
11878
4c4b4cd2
PH
11879/* True iff NAME is the name of a range type. */
11880
14f9c5c9 11881int
d2e4a39e 11882ada_is_range_type_name (const char *name)
14f9c5c9
AS
11883{
11884 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11885}
14f9c5c9 11886\f
d2e4a39e 11887
4c4b4cd2
PH
11888 /* Modular types */
11889
11890/* True iff TYPE is an Ada modular type. */
14f9c5c9 11891
14f9c5c9 11892int
d2e4a39e 11893ada_is_modular_type (struct type *type)
14f9c5c9 11894{
18af8284 11895 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11896
11897 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11898 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11899 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11900}
11901
4c4b4cd2
PH
11902/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11903
61ee279c 11904ULONGEST
0056e4d5 11905ada_modulus (struct type *type)
14f9c5c9 11906{
43bbcdc2 11907 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11908}
d2e4a39e 11909\f
f7f9143b
JB
11910
11911/* Ada exception catchpoint support:
11912 ---------------------------------
11913
11914 We support 3 kinds of exception catchpoints:
11915 . catchpoints on Ada exceptions
11916 . catchpoints on unhandled Ada exceptions
11917 . catchpoints on failed assertions
11918
11919 Exceptions raised during failed assertions, or unhandled exceptions
11920 could perfectly be caught with the general catchpoint on Ada exceptions.
11921 However, we can easily differentiate these two special cases, and having
11922 the option to distinguish these two cases from the rest can be useful
11923 to zero-in on certain situations.
11924
11925 Exception catchpoints are a specialized form of breakpoint,
11926 since they rely on inserting breakpoints inside known routines
11927 of the GNAT runtime. The implementation therefore uses a standard
11928 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11929 of breakpoint_ops.
11930
0259addd
JB
11931 Support in the runtime for exception catchpoints have been changed
11932 a few times already, and these changes affect the implementation
11933 of these catchpoints. In order to be able to support several
11934 variants of the runtime, we use a sniffer that will determine
28010a5d 11935 the runtime variant used by the program being debugged. */
f7f9143b 11936
82eacd52
JB
11937/* Ada's standard exceptions.
11938
11939 The Ada 83 standard also defined Numeric_Error. But there so many
11940 situations where it was unclear from the Ada 83 Reference Manual
11941 (RM) whether Constraint_Error or Numeric_Error should be raised,
11942 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11943 Interpretation saying that anytime the RM says that Numeric_Error
11944 should be raised, the implementation may raise Constraint_Error.
11945 Ada 95 went one step further and pretty much removed Numeric_Error
11946 from the list of standard exceptions (it made it a renaming of
11947 Constraint_Error, to help preserve compatibility when compiling
11948 an Ada83 compiler). As such, we do not include Numeric_Error from
11949 this list of standard exceptions. */
3d0b0fa3 11950
a121b7c1 11951static const char *standard_exc[] = {
3d0b0fa3
JB
11952 "constraint_error",
11953 "program_error",
11954 "storage_error",
11955 "tasking_error"
11956};
11957
0259addd
JB
11958typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11959
11960/* A structure that describes how to support exception catchpoints
11961 for a given executable. */
11962
11963struct exception_support_info
11964{
11965 /* The name of the symbol to break on in order to insert
11966 a catchpoint on exceptions. */
11967 const char *catch_exception_sym;
11968
11969 /* The name of the symbol to break on in order to insert
11970 a catchpoint on unhandled exceptions. */
11971 const char *catch_exception_unhandled_sym;
11972
11973 /* The name of the symbol to break on in order to insert
11974 a catchpoint on failed assertions. */
11975 const char *catch_assert_sym;
11976
9f757bf7
XR
11977 /* The name of the symbol to break on in order to insert
11978 a catchpoint on exception handling. */
11979 const char *catch_handlers_sym;
11980
0259addd
JB
11981 /* Assuming that the inferior just triggered an unhandled exception
11982 catchpoint, this function is responsible for returning the address
11983 in inferior memory where the name of that exception is stored.
11984 Return zero if the address could not be computed. */
11985 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11986};
11987
11988static CORE_ADDR ada_unhandled_exception_name_addr (void);
11989static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11990
11991/* The following exception support info structure describes how to
11992 implement exception catchpoints with the latest version of the
11993 Ada runtime (as of 2007-03-06). */
11994
11995static const struct exception_support_info default_exception_support_info =
11996{
11997 "__gnat_debug_raise_exception", /* catch_exception_sym */
11998 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11999 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9f757bf7 12000 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12001 ada_unhandled_exception_name_addr
12002};
12003
12004/* The following exception support info structure describes how to
12005 implement exception catchpoints with a slightly older version
12006 of the Ada runtime. */
12007
12008static const struct exception_support_info exception_support_info_fallback =
12009{
12010 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12011 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12012 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9f757bf7 12013 "__gnat_begin_handler", /* catch_handlers_sym */
0259addd
JB
12014 ada_unhandled_exception_name_addr_from_raise
12015};
12016
f17011e0
JB
12017/* Return nonzero if we can detect the exception support routines
12018 described in EINFO.
12019
12020 This function errors out if an abnormal situation is detected
12021 (for instance, if we find the exception support routines, but
12022 that support is found to be incomplete). */
12023
12024static int
12025ada_has_this_exception_support (const struct exception_support_info *einfo)
12026{
12027 struct symbol *sym;
12028
12029 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12030 that should be compiled with debugging information. As a result, we
12031 expect to find that symbol in the symtabs. */
12032
12033 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12034 if (sym == NULL)
a6af7abe
JB
12035 {
12036 /* Perhaps we did not find our symbol because the Ada runtime was
12037 compiled without debugging info, or simply stripped of it.
12038 It happens on some GNU/Linux distributions for instance, where
12039 users have to install a separate debug package in order to get
12040 the runtime's debugging info. In that situation, let the user
12041 know why we cannot insert an Ada exception catchpoint.
12042
12043 Note: Just for the purpose of inserting our Ada exception
12044 catchpoint, we could rely purely on the associated minimal symbol.
12045 But we would be operating in degraded mode anyway, since we are
12046 still lacking the debugging info needed later on to extract
12047 the name of the exception being raised (this name is printed in
12048 the catchpoint message, and is also used when trying to catch
12049 a specific exception). We do not handle this case for now. */
3b7344d5 12050 struct bound_minimal_symbol msym
1c8e84b0
JB
12051 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12052
3b7344d5 12053 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
12054 error (_("Your Ada runtime appears to be missing some debugging "
12055 "information.\nCannot insert Ada exception catchpoint "
12056 "in this configuration."));
12057
12058 return 0;
12059 }
f17011e0
JB
12060
12061 /* Make sure that the symbol we found corresponds to a function. */
12062
12063 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12064 error (_("Symbol \"%s\" is not a function (class = %d)"),
12065 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12066
12067 return 1;
12068}
12069
0259addd
JB
12070/* Inspect the Ada runtime and determine which exception info structure
12071 should be used to provide support for exception catchpoints.
12072
3eecfa55
JB
12073 This function will always set the per-inferior exception_info,
12074 or raise an error. */
0259addd
JB
12075
12076static void
12077ada_exception_support_info_sniffer (void)
12078{
3eecfa55 12079 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
12080
12081 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 12082 if (data->exception_info != NULL)
0259addd
JB
12083 return;
12084
12085 /* Check the latest (default) exception support info. */
f17011e0 12086 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 12087 {
3eecfa55 12088 data->exception_info = &default_exception_support_info;
0259addd
JB
12089 return;
12090 }
12091
12092 /* Try our fallback exception suport info. */
f17011e0 12093 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 12094 {
3eecfa55 12095 data->exception_info = &exception_support_info_fallback;
0259addd
JB
12096 return;
12097 }
12098
12099 /* Sometimes, it is normal for us to not be able to find the routine
12100 we are looking for. This happens when the program is linked with
12101 the shared version of the GNAT runtime, and the program has not been
12102 started yet. Inform the user of these two possible causes if
12103 applicable. */
12104
ccefe4c4 12105 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
12106 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12107
12108 /* If the symbol does not exist, then check that the program is
12109 already started, to make sure that shared libraries have been
12110 loaded. If it is not started, this may mean that the symbol is
12111 in a shared library. */
12112
e99b03dc 12113 if (inferior_ptid.pid () == 0)
0259addd
JB
12114 error (_("Unable to insert catchpoint. Try to start the program first."));
12115
12116 /* At this point, we know that we are debugging an Ada program and
12117 that the inferior has been started, but we still are not able to
0963b4bd 12118 find the run-time symbols. That can mean that we are in
0259addd
JB
12119 configurable run time mode, or that a-except as been optimized
12120 out by the linker... In any case, at this point it is not worth
12121 supporting this feature. */
12122
7dda8cff 12123 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12124}
12125
f7f9143b
JB
12126/* True iff FRAME is very likely to be that of a function that is
12127 part of the runtime system. This is all very heuristic, but is
12128 intended to be used as advice as to what frames are uninteresting
12129 to most users. */
12130
12131static int
12132is_known_support_routine (struct frame_info *frame)
12133{
692465f1 12134 enum language func_lang;
f7f9143b 12135 int i;
f35a17b5 12136 const char *fullname;
f7f9143b 12137
4ed6b5be
JB
12138 /* If this code does not have any debugging information (no symtab),
12139 This cannot be any user code. */
f7f9143b 12140
51abb421 12141 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
12142 if (sal.symtab == NULL)
12143 return 1;
12144
4ed6b5be
JB
12145 /* If there is a symtab, but the associated source file cannot be
12146 located, then assume this is not user code: Selecting a frame
12147 for which we cannot display the code would not be very helpful
12148 for the user. This should also take care of case such as VxWorks
12149 where the kernel has some debugging info provided for a few units. */
f7f9143b 12150
f35a17b5
JK
12151 fullname = symtab_to_fullname (sal.symtab);
12152 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12153 return 1;
12154
4ed6b5be
JB
12155 /* Check the unit filename againt the Ada runtime file naming.
12156 We also check the name of the objfile against the name of some
12157 known system libraries that sometimes come with debugging info
12158 too. */
12159
f7f9143b
JB
12160 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12161 {
12162 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12163 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12164 return 1;
eb822aa6
DE
12165 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12166 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12167 return 1;
f7f9143b
JB
12168 }
12169
4ed6b5be 12170 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12171
c6dc63a1
TT
12172 gdb::unique_xmalloc_ptr<char> func_name
12173 = find_frame_funname (frame, &func_lang, NULL);
f7f9143b
JB
12174 if (func_name == NULL)
12175 return 1;
12176
12177 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12178 {
12179 re_comp (known_auxiliary_function_name_patterns[i]);
c6dc63a1
TT
12180 if (re_exec (func_name.get ()))
12181 return 1;
f7f9143b
JB
12182 }
12183
12184 return 0;
12185}
12186
12187/* Find the first frame that contains debugging information and that is not
12188 part of the Ada run-time, starting from FI and moving upward. */
12189
0ef643c8 12190void
f7f9143b
JB
12191ada_find_printable_frame (struct frame_info *fi)
12192{
12193 for (; fi != NULL; fi = get_prev_frame (fi))
12194 {
12195 if (!is_known_support_routine (fi))
12196 {
12197 select_frame (fi);
12198 break;
12199 }
12200 }
12201
12202}
12203
12204/* Assuming that the inferior just triggered an unhandled exception
12205 catchpoint, return the address in inferior memory where the name
12206 of the exception is stored.
12207
12208 Return zero if the address could not be computed. */
12209
12210static CORE_ADDR
12211ada_unhandled_exception_name_addr (void)
0259addd
JB
12212{
12213 return parse_and_eval_address ("e.full_name");
12214}
12215
12216/* Same as ada_unhandled_exception_name_addr, except that this function
12217 should be used when the inferior uses an older version of the runtime,
12218 where the exception name needs to be extracted from a specific frame
12219 several frames up in the callstack. */
12220
12221static CORE_ADDR
12222ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12223{
12224 int frame_level;
12225 struct frame_info *fi;
3eecfa55 12226 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
f7f9143b
JB
12227
12228 /* To determine the name of this exception, we need to select
12229 the frame corresponding to RAISE_SYM_NAME. This frame is
12230 at least 3 levels up, so we simply skip the first 3 frames
12231 without checking the name of their associated function. */
12232 fi = get_current_frame ();
12233 for (frame_level = 0; frame_level < 3; frame_level += 1)
12234 if (fi != NULL)
12235 fi = get_prev_frame (fi);
12236
12237 while (fi != NULL)
12238 {
692465f1
JB
12239 enum language func_lang;
12240
c6dc63a1
TT
12241 gdb::unique_xmalloc_ptr<char> func_name
12242 = find_frame_funname (fi, &func_lang, NULL);
55b87a52
KS
12243 if (func_name != NULL)
12244 {
c6dc63a1 12245 if (strcmp (func_name.get (),
55b87a52
KS
12246 data->exception_info->catch_exception_sym) == 0)
12247 break; /* We found the frame we were looking for... */
55b87a52 12248 }
fb44b1a7 12249 fi = get_prev_frame (fi);
f7f9143b
JB
12250 }
12251
12252 if (fi == NULL)
12253 return 0;
12254
12255 select_frame (fi);
12256 return parse_and_eval_address ("id.full_name");
12257}
12258
12259/* Assuming the inferior just triggered an Ada exception catchpoint
12260 (of any type), return the address in inferior memory where the name
12261 of the exception is stored, if applicable.
12262
45db7c09
PA
12263 Assumes the selected frame is the current frame.
12264
f7f9143b
JB
12265 Return zero if the address could not be computed, or if not relevant. */
12266
12267static CORE_ADDR
761269c8 12268ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12269 struct breakpoint *b)
12270{
3eecfa55
JB
12271 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12272
f7f9143b
JB
12273 switch (ex)
12274 {
761269c8 12275 case ada_catch_exception:
f7f9143b
JB
12276 return (parse_and_eval_address ("e.full_name"));
12277 break;
12278
761269c8 12279 case ada_catch_exception_unhandled:
3eecfa55 12280 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b 12281 break;
9f757bf7
XR
12282
12283 case ada_catch_handlers:
12284 return 0; /* The runtimes does not provide access to the exception
12285 name. */
12286 break;
12287
761269c8 12288 case ada_catch_assert:
f7f9143b
JB
12289 return 0; /* Exception name is not relevant in this case. */
12290 break;
12291
12292 default:
12293 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12294 break;
12295 }
12296
12297 return 0; /* Should never be reached. */
12298}
12299
e547c119
JB
12300/* Assuming the inferior is stopped at an exception catchpoint,
12301 return the message which was associated to the exception, if
12302 available. Return NULL if the message could not be retrieved.
12303
e547c119
JB
12304 Note: The exception message can be associated to an exception
12305 either through the use of the Raise_Exception function, or
12306 more simply (Ada 2005 and later), via:
12307
12308 raise Exception_Name with "exception message";
12309
12310 */
12311
6f46ac85 12312static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12313ada_exception_message_1 (void)
12314{
12315 struct value *e_msg_val;
e547c119 12316 int e_msg_len;
e547c119
JB
12317
12318 /* For runtimes that support this feature, the exception message
12319 is passed as an unbounded string argument called "message". */
12320 e_msg_val = parse_and_eval ("message");
12321 if (e_msg_val == NULL)
12322 return NULL; /* Exception message not supported. */
12323
12324 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12325 gdb_assert (e_msg_val != NULL);
12326 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12327
12328 /* If the message string is empty, then treat it as if there was
12329 no exception message. */
12330 if (e_msg_len <= 0)
12331 return NULL;
12332
6f46ac85
TT
12333 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1));
12334 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1);
12335 e_msg.get ()[e_msg_len] = '\0';
e547c119 12336
e547c119
JB
12337 return e_msg;
12338}
12339
12340/* Same as ada_exception_message_1, except that all exceptions are
12341 contained here (returning NULL instead). */
12342
6f46ac85 12343static gdb::unique_xmalloc_ptr<char>
e547c119
JB
12344ada_exception_message (void)
12345{
6f46ac85 12346 gdb::unique_xmalloc_ptr<char> e_msg;
e547c119
JB
12347
12348 TRY
12349 {
12350 e_msg = ada_exception_message_1 ();
12351 }
12352 CATCH (e, RETURN_MASK_ERROR)
12353 {
6f46ac85 12354 e_msg.reset (nullptr);
e547c119
JB
12355 }
12356 END_CATCH
12357
12358 return e_msg;
12359}
12360
f7f9143b
JB
12361/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12362 any error that ada_exception_name_addr_1 might cause to be thrown.
12363 When an error is intercepted, a warning with the error message is printed,
12364 and zero is returned. */
12365
12366static CORE_ADDR
761269c8 12367ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12368 struct breakpoint *b)
12369{
f7f9143b
JB
12370 CORE_ADDR result = 0;
12371
492d29ea 12372 TRY
f7f9143b
JB
12373 {
12374 result = ada_exception_name_addr_1 (ex, b);
12375 }
12376
492d29ea 12377 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12378 {
12379 warning (_("failed to get exception name: %s"), e.message);
12380 return 0;
12381 }
492d29ea 12382 END_CATCH
f7f9143b
JB
12383
12384 return result;
12385}
12386
cb7de75e 12387static std::string ada_exception_catchpoint_cond_string
9f757bf7
XR
12388 (const char *excep_string,
12389 enum ada_exception_catchpoint_kind ex);
28010a5d
PA
12390
12391/* Ada catchpoints.
12392
12393 In the case of catchpoints on Ada exceptions, the catchpoint will
12394 stop the target on every exception the program throws. When a user
12395 specifies the name of a specific exception, we translate this
12396 request into a condition expression (in text form), and then parse
12397 it into an expression stored in each of the catchpoint's locations.
12398 We then use this condition to check whether the exception that was
12399 raised is the one the user is interested in. If not, then the
12400 target is resumed again. We store the name of the requested
12401 exception, in order to be able to re-set the condition expression
12402 when symbols change. */
12403
12404/* An instance of this type is used to represent an Ada catchpoint
5625a286 12405 breakpoint location. */
28010a5d 12406
5625a286 12407class ada_catchpoint_location : public bp_location
28010a5d 12408{
5625a286
PA
12409public:
12410 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12411 : bp_location (ops, owner)
12412 {}
28010a5d
PA
12413
12414 /* The condition that checks whether the exception that was raised
12415 is the specific exception the user specified on catchpoint
12416 creation. */
4d01a485 12417 expression_up excep_cond_expr;
28010a5d
PA
12418};
12419
12420/* Implement the DTOR method in the bp_location_ops structure for all
12421 Ada exception catchpoint kinds. */
12422
12423static void
12424ada_catchpoint_location_dtor (struct bp_location *bl)
12425{
12426 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12427
4d01a485 12428 al->excep_cond_expr.reset ();
28010a5d
PA
12429}
12430
12431/* The vtable to be used in Ada catchpoint locations. */
12432
12433static const struct bp_location_ops ada_catchpoint_location_ops =
12434{
12435 ada_catchpoint_location_dtor
12436};
12437
c1fc2657 12438/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12439
c1fc2657 12440struct ada_catchpoint : public breakpoint
28010a5d 12441{
28010a5d 12442 /* The name of the specific exception the user specified. */
bc18fbb5 12443 std::string excep_string;
28010a5d
PA
12444};
12445
12446/* Parse the exception condition string in the context of each of the
12447 catchpoint's locations, and store them for later evaluation. */
12448
12449static void
9f757bf7
XR
12450create_excep_cond_exprs (struct ada_catchpoint *c,
12451 enum ada_exception_catchpoint_kind ex)
28010a5d 12452{
28010a5d 12453 struct bp_location *bl;
28010a5d
PA
12454
12455 /* Nothing to do if there's no specific exception to catch. */
bc18fbb5 12456 if (c->excep_string.empty ())
28010a5d
PA
12457 return;
12458
12459 /* Same if there are no locations... */
c1fc2657 12460 if (c->loc == NULL)
28010a5d
PA
12461 return;
12462
12463 /* Compute the condition expression in text form, from the specific
12464 expection we want to catch. */
cb7de75e 12465 std::string cond_string
bc18fbb5 12466 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex);
28010a5d
PA
12467
12468 /* Iterate over all the catchpoint's locations, and parse an
12469 expression for each. */
c1fc2657 12470 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12471 {
12472 struct ada_catchpoint_location *ada_loc
12473 = (struct ada_catchpoint_location *) bl;
4d01a485 12474 expression_up exp;
28010a5d
PA
12475
12476 if (!bl->shlib_disabled)
12477 {
bbc13ae3 12478 const char *s;
28010a5d 12479
cb7de75e 12480 s = cond_string.c_str ();
492d29ea 12481 TRY
28010a5d 12482 {
036e657b
JB
12483 exp = parse_exp_1 (&s, bl->address,
12484 block_for_pc (bl->address),
12485 0);
28010a5d 12486 }
492d29ea 12487 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12488 {
12489 warning (_("failed to reevaluate internal exception condition "
12490 "for catchpoint %d: %s"),
c1fc2657 12491 c->number, e.message);
849f2b52 12492 }
492d29ea 12493 END_CATCH
28010a5d
PA
12494 }
12495
b22e99fd 12496 ada_loc->excep_cond_expr = std::move (exp);
28010a5d 12497 }
28010a5d
PA
12498}
12499
28010a5d
PA
12500/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12501 structure for all exception catchpoint kinds. */
12502
12503static struct bp_location *
761269c8 12504allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12505 struct breakpoint *self)
12506{
5625a286 12507 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12508}
12509
12510/* Implement the RE_SET method in the breakpoint_ops structure for all
12511 exception catchpoint kinds. */
12512
12513static void
761269c8 12514re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12515{
12516 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12517
12518 /* Call the base class's method. This updates the catchpoint's
12519 locations. */
2060206e 12520 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12521
12522 /* Reparse the exception conditional expressions. One for each
12523 location. */
9f757bf7 12524 create_excep_cond_exprs (c, ex);
28010a5d
PA
12525}
12526
12527/* Returns true if we should stop for this breakpoint hit. If the
12528 user specified a specific exception, we only want to cause a stop
12529 if the program thrown that exception. */
12530
12531static int
12532should_stop_exception (const struct bp_location *bl)
12533{
12534 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12535 const struct ada_catchpoint_location *ada_loc
12536 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12537 int stop;
12538
12539 /* With no specific exception, should always stop. */
bc18fbb5 12540 if (c->excep_string.empty ())
28010a5d
PA
12541 return 1;
12542
12543 if (ada_loc->excep_cond_expr == NULL)
12544 {
12545 /* We will have a NULL expression if back when we were creating
12546 the expressions, this location's had failed to parse. */
12547 return 1;
12548 }
12549
12550 stop = 1;
492d29ea 12551 TRY
28010a5d
PA
12552 {
12553 struct value *mark;
12554
12555 mark = value_mark ();
4d01a485 12556 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12557 value_free_to_mark (mark);
12558 }
492d29ea
PA
12559 CATCH (ex, RETURN_MASK_ALL)
12560 {
12561 exception_fprintf (gdb_stderr, ex,
12562 _("Error in testing exception condition:\n"));
12563 }
12564 END_CATCH
12565
28010a5d
PA
12566 return stop;
12567}
12568
12569/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12570 for all exception catchpoint kinds. */
12571
12572static void
761269c8 12573check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12574{
12575 bs->stop = should_stop_exception (bs->bp_location_at);
12576}
12577
f7f9143b
JB
12578/* Implement the PRINT_IT method in the breakpoint_ops structure
12579 for all exception catchpoint kinds. */
12580
12581static enum print_stop_action
761269c8 12582print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12583{
79a45e25 12584 struct ui_out *uiout = current_uiout;
348d480f
PA
12585 struct breakpoint *b = bs->breakpoint_at;
12586
956a9fb9 12587 annotate_catchpoint (b->number);
f7f9143b 12588
112e8700 12589 if (uiout->is_mi_like_p ())
f7f9143b 12590 {
112e8700 12591 uiout->field_string ("reason",
956a9fb9 12592 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12593 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12594 }
12595
112e8700
SM
12596 uiout->text (b->disposition == disp_del
12597 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12598 uiout->field_int ("bkptno", b->number);
12599 uiout->text (", ");
f7f9143b 12600
45db7c09
PA
12601 /* ada_exception_name_addr relies on the selected frame being the
12602 current frame. Need to do this here because this function may be
12603 called more than once when printing a stop, and below, we'll
12604 select the first frame past the Ada run-time (see
12605 ada_find_printable_frame). */
12606 select_frame (get_current_frame ());
12607
f7f9143b
JB
12608 switch (ex)
12609 {
761269c8
JB
12610 case ada_catch_exception:
12611 case ada_catch_exception_unhandled:
9f757bf7 12612 case ada_catch_handlers:
956a9fb9
JB
12613 {
12614 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12615 char exception_name[256];
12616
12617 if (addr != 0)
12618 {
c714b426
PA
12619 read_memory (addr, (gdb_byte *) exception_name,
12620 sizeof (exception_name) - 1);
956a9fb9
JB
12621 exception_name [sizeof (exception_name) - 1] = '\0';
12622 }
12623 else
12624 {
12625 /* For some reason, we were unable to read the exception
12626 name. This could happen if the Runtime was compiled
12627 without debugging info, for instance. In that case,
12628 just replace the exception name by the generic string
12629 "exception" - it will read as "an exception" in the
12630 notification we are about to print. */
967cff16 12631 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12632 }
12633 /* In the case of unhandled exception breakpoints, we print
12634 the exception name as "unhandled EXCEPTION_NAME", to make
12635 it clearer to the user which kind of catchpoint just got
12636 hit. We used ui_out_text to make sure that this extra
12637 info does not pollute the exception name in the MI case. */
761269c8 12638 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12639 uiout->text ("unhandled ");
12640 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12641 }
12642 break;
761269c8 12643 case ada_catch_assert:
956a9fb9
JB
12644 /* In this case, the name of the exception is not really
12645 important. Just print "failed assertion" to make it clearer
12646 that his program just hit an assertion-failure catchpoint.
12647 We used ui_out_text because this info does not belong in
12648 the MI output. */
112e8700 12649 uiout->text ("failed assertion");
956a9fb9 12650 break;
f7f9143b 12651 }
e547c119 12652
6f46ac85 12653 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message ();
e547c119
JB
12654 if (exception_message != NULL)
12655 {
e547c119 12656 uiout->text (" (");
6f46ac85 12657 uiout->field_string ("exception-message", exception_message.get ());
e547c119 12658 uiout->text (")");
e547c119
JB
12659 }
12660
112e8700 12661 uiout->text (" at ");
956a9fb9 12662 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12663
12664 return PRINT_SRC_AND_LOC;
12665}
12666
12667/* Implement the PRINT_ONE method in the breakpoint_ops structure
12668 for all exception catchpoint kinds. */
12669
12670static void
761269c8 12671print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12672 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12673{
79a45e25 12674 struct ui_out *uiout = current_uiout;
28010a5d 12675 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12676 struct value_print_options opts;
12677
12678 get_user_print_options (&opts);
12679 if (opts.addressprint)
f7f9143b
JB
12680 {
12681 annotate_field (4);
112e8700 12682 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12683 }
12684
12685 annotate_field (5);
a6d9a66e 12686 *last_loc = b->loc;
f7f9143b
JB
12687 switch (ex)
12688 {
761269c8 12689 case ada_catch_exception:
bc18fbb5 12690 if (!c->excep_string.empty ())
f7f9143b 12691 {
bc18fbb5
TT
12692 std::string msg = string_printf (_("`%s' Ada exception"),
12693 c->excep_string.c_str ());
28010a5d 12694
112e8700 12695 uiout->field_string ("what", msg);
f7f9143b
JB
12696 }
12697 else
112e8700 12698 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12699
12700 break;
12701
761269c8 12702 case ada_catch_exception_unhandled:
112e8700 12703 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12704 break;
12705
9f757bf7 12706 case ada_catch_handlers:
bc18fbb5 12707 if (!c->excep_string.empty ())
9f757bf7
XR
12708 {
12709 uiout->field_fmt ("what",
12710 _("`%s' Ada exception handlers"),
bc18fbb5 12711 c->excep_string.c_str ());
9f757bf7
XR
12712 }
12713 else
12714 uiout->field_string ("what", "all Ada exceptions handlers");
12715 break;
12716
761269c8 12717 case ada_catch_assert:
112e8700 12718 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12719 break;
12720
12721 default:
12722 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12723 break;
12724 }
12725}
12726
12727/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12728 for all exception catchpoint kinds. */
12729
12730static void
761269c8 12731print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12732 struct breakpoint *b)
12733{
28010a5d 12734 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12735 struct ui_out *uiout = current_uiout;
28010a5d 12736
112e8700 12737 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12738 : _("Catchpoint "));
112e8700
SM
12739 uiout->field_int ("bkptno", b->number);
12740 uiout->text (": ");
00eb2c4a 12741
f7f9143b
JB
12742 switch (ex)
12743 {
761269c8 12744 case ada_catch_exception:
bc18fbb5 12745 if (!c->excep_string.empty ())
00eb2c4a 12746 {
862d101a 12747 std::string info = string_printf (_("`%s' Ada exception"),
bc18fbb5 12748 c->excep_string.c_str ());
862d101a 12749 uiout->text (info.c_str ());
00eb2c4a 12750 }
f7f9143b 12751 else
112e8700 12752 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12753 break;
12754
761269c8 12755 case ada_catch_exception_unhandled:
112e8700 12756 uiout->text (_("unhandled Ada exceptions"));
f7f9143b 12757 break;
9f757bf7
XR
12758
12759 case ada_catch_handlers:
bc18fbb5 12760 if (!c->excep_string.empty ())
9f757bf7
XR
12761 {
12762 std::string info
12763 = string_printf (_("`%s' Ada exception handlers"),
bc18fbb5 12764 c->excep_string.c_str ());
9f757bf7
XR
12765 uiout->text (info.c_str ());
12766 }
12767 else
12768 uiout->text (_("all Ada exceptions handlers"));
12769 break;
12770
761269c8 12771 case ada_catch_assert:
112e8700 12772 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12773 break;
12774
12775 default:
12776 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12777 break;
12778 }
12779}
12780
6149aea9
PA
12781/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12782 for all exception catchpoint kinds. */
12783
12784static void
761269c8 12785print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12786 struct breakpoint *b, struct ui_file *fp)
12787{
28010a5d
PA
12788 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12789
6149aea9
PA
12790 switch (ex)
12791 {
761269c8 12792 case ada_catch_exception:
6149aea9 12793 fprintf_filtered (fp, "catch exception");
bc18fbb5
TT
12794 if (!c->excep_string.empty ())
12795 fprintf_filtered (fp, " %s", c->excep_string.c_str ());
6149aea9
PA
12796 break;
12797
761269c8 12798 case ada_catch_exception_unhandled:
78076abc 12799 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12800 break;
12801
9f757bf7
XR
12802 case ada_catch_handlers:
12803 fprintf_filtered (fp, "catch handlers");
12804 break;
12805
761269c8 12806 case ada_catch_assert:
6149aea9
PA
12807 fprintf_filtered (fp, "catch assert");
12808 break;
12809
12810 default:
12811 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12812 }
d9b3f62e 12813 print_recreate_thread (b, fp);
6149aea9
PA
12814}
12815
f7f9143b
JB
12816/* Virtual table for "catch exception" breakpoints. */
12817
28010a5d
PA
12818static struct bp_location *
12819allocate_location_catch_exception (struct breakpoint *self)
12820{
761269c8 12821 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12822}
12823
12824static void
12825re_set_catch_exception (struct breakpoint *b)
12826{
761269c8 12827 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12828}
12829
12830static void
12831check_status_catch_exception (bpstat bs)
12832{
761269c8 12833 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12834}
12835
f7f9143b 12836static enum print_stop_action
348d480f 12837print_it_catch_exception (bpstat bs)
f7f9143b 12838{
761269c8 12839 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12840}
12841
12842static void
a6d9a66e 12843print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12844{
761269c8 12845 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12846}
12847
12848static void
12849print_mention_catch_exception (struct breakpoint *b)
12850{
761269c8 12851 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12852}
12853
6149aea9
PA
12854static void
12855print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12856{
761269c8 12857 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12858}
12859
2060206e 12860static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12861
12862/* Virtual table for "catch exception unhandled" breakpoints. */
12863
28010a5d
PA
12864static struct bp_location *
12865allocate_location_catch_exception_unhandled (struct breakpoint *self)
12866{
761269c8 12867 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12868}
12869
12870static void
12871re_set_catch_exception_unhandled (struct breakpoint *b)
12872{
761269c8 12873 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12874}
12875
12876static void
12877check_status_catch_exception_unhandled (bpstat bs)
12878{
761269c8 12879 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12880}
12881
f7f9143b 12882static enum print_stop_action
348d480f 12883print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12884{
761269c8 12885 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12886}
12887
12888static void
a6d9a66e
UW
12889print_one_catch_exception_unhandled (struct breakpoint *b,
12890 struct bp_location **last_loc)
f7f9143b 12891{
761269c8 12892 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12893}
12894
12895static void
12896print_mention_catch_exception_unhandled (struct breakpoint *b)
12897{
761269c8 12898 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12899}
12900
6149aea9
PA
12901static void
12902print_recreate_catch_exception_unhandled (struct breakpoint *b,
12903 struct ui_file *fp)
12904{
761269c8 12905 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12906}
12907
2060206e 12908static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12909
12910/* Virtual table for "catch assert" breakpoints. */
12911
28010a5d
PA
12912static struct bp_location *
12913allocate_location_catch_assert (struct breakpoint *self)
12914{
761269c8 12915 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12916}
12917
12918static void
12919re_set_catch_assert (struct breakpoint *b)
12920{
761269c8 12921 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12922}
12923
12924static void
12925check_status_catch_assert (bpstat bs)
12926{
761269c8 12927 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12928}
12929
f7f9143b 12930static enum print_stop_action
348d480f 12931print_it_catch_assert (bpstat bs)
f7f9143b 12932{
761269c8 12933 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12934}
12935
12936static void
a6d9a66e 12937print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12938{
761269c8 12939 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12940}
12941
12942static void
12943print_mention_catch_assert (struct breakpoint *b)
12944{
761269c8 12945 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12946}
12947
6149aea9
PA
12948static void
12949print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12950{
761269c8 12951 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12952}
12953
2060206e 12954static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12955
9f757bf7
XR
12956/* Virtual table for "catch handlers" breakpoints. */
12957
12958static struct bp_location *
12959allocate_location_catch_handlers (struct breakpoint *self)
12960{
12961 return allocate_location_exception (ada_catch_handlers, self);
12962}
12963
12964static void
12965re_set_catch_handlers (struct breakpoint *b)
12966{
12967 re_set_exception (ada_catch_handlers, b);
12968}
12969
12970static void
12971check_status_catch_handlers (bpstat bs)
12972{
12973 check_status_exception (ada_catch_handlers, bs);
12974}
12975
12976static enum print_stop_action
12977print_it_catch_handlers (bpstat bs)
12978{
12979 return print_it_exception (ada_catch_handlers, bs);
12980}
12981
12982static void
12983print_one_catch_handlers (struct breakpoint *b,
12984 struct bp_location **last_loc)
12985{
12986 print_one_exception (ada_catch_handlers, b, last_loc);
12987}
12988
12989static void
12990print_mention_catch_handlers (struct breakpoint *b)
12991{
12992 print_mention_exception (ada_catch_handlers, b);
12993}
12994
12995static void
12996print_recreate_catch_handlers (struct breakpoint *b,
12997 struct ui_file *fp)
12998{
12999 print_recreate_exception (ada_catch_handlers, b, fp);
13000}
13001
13002static struct breakpoint_ops catch_handlers_breakpoint_ops;
13003
f7f9143b
JB
13004/* Split the arguments specified in a "catch exception" command.
13005 Set EX to the appropriate catchpoint type.
28010a5d 13006 Set EXCEP_STRING to the name of the specific exception if
5845583d 13007 specified by the user.
9f757bf7
XR
13008 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13009 "catch handlers" command. False otherwise.
5845583d
JB
13010 If a condition is found at the end of the arguments, the condition
13011 expression is stored in COND_STRING (memory must be deallocated
13012 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
13013
13014static void
a121b7c1 13015catch_ada_exception_command_split (const char *args,
9f757bf7 13016 bool is_catch_handlers_cmd,
761269c8 13017 enum ada_exception_catchpoint_kind *ex,
bc18fbb5
TT
13018 std::string *excep_string,
13019 std::string *cond_string)
f7f9143b 13020{
bc18fbb5 13021 std::string exception_name;
f7f9143b 13022
bc18fbb5
TT
13023 exception_name = extract_arg (&args);
13024 if (exception_name == "if")
5845583d
JB
13025 {
13026 /* This is not an exception name; this is the start of a condition
13027 expression for a catchpoint on all exceptions. So, "un-get"
13028 this token, and set exception_name to NULL. */
bc18fbb5 13029 exception_name.clear ();
5845583d
JB
13030 args -= 2;
13031 }
f7f9143b 13032
5845583d 13033 /* Check to see if we have a condition. */
f7f9143b 13034
f1735a53 13035 args = skip_spaces (args);
61012eef 13036 if (startswith (args, "if")
5845583d
JB
13037 && (isspace (args[2]) || args[2] == '\0'))
13038 {
13039 args += 2;
f1735a53 13040 args = skip_spaces (args);
5845583d
JB
13041
13042 if (args[0] == '\0')
13043 error (_("Condition missing after `if' keyword"));
bc18fbb5 13044 *cond_string = args;
5845583d
JB
13045
13046 args += strlen (args);
13047 }
13048
13049 /* Check that we do not have any more arguments. Anything else
13050 is unexpected. */
f7f9143b
JB
13051
13052 if (args[0] != '\0')
13053 error (_("Junk at end of expression"));
13054
9f757bf7
XR
13055 if (is_catch_handlers_cmd)
13056 {
13057 /* Catch handling of exceptions. */
13058 *ex = ada_catch_handlers;
13059 *excep_string = exception_name;
13060 }
bc18fbb5 13061 else if (exception_name.empty ())
f7f9143b
JB
13062 {
13063 /* Catch all exceptions. */
761269c8 13064 *ex = ada_catch_exception;
bc18fbb5 13065 excep_string->clear ();
f7f9143b 13066 }
bc18fbb5 13067 else if (exception_name == "unhandled")
f7f9143b
JB
13068 {
13069 /* Catch unhandled exceptions. */
761269c8 13070 *ex = ada_catch_exception_unhandled;
bc18fbb5 13071 excep_string->clear ();
f7f9143b
JB
13072 }
13073 else
13074 {
13075 /* Catch a specific exception. */
761269c8 13076 *ex = ada_catch_exception;
28010a5d 13077 *excep_string = exception_name;
f7f9143b
JB
13078 }
13079}
13080
13081/* Return the name of the symbol on which we should break in order to
13082 implement a catchpoint of the EX kind. */
13083
13084static const char *
761269c8 13085ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 13086{
3eecfa55
JB
13087 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13088
13089 gdb_assert (data->exception_info != NULL);
0259addd 13090
f7f9143b
JB
13091 switch (ex)
13092 {
761269c8 13093 case ada_catch_exception:
3eecfa55 13094 return (data->exception_info->catch_exception_sym);
f7f9143b 13095 break;
761269c8 13096 case ada_catch_exception_unhandled:
3eecfa55 13097 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 13098 break;
761269c8 13099 case ada_catch_assert:
3eecfa55 13100 return (data->exception_info->catch_assert_sym);
f7f9143b 13101 break;
9f757bf7
XR
13102 case ada_catch_handlers:
13103 return (data->exception_info->catch_handlers_sym);
13104 break;
f7f9143b
JB
13105 default:
13106 internal_error (__FILE__, __LINE__,
13107 _("unexpected catchpoint kind (%d)"), ex);
13108 }
13109}
13110
13111/* Return the breakpoint ops "virtual table" used for catchpoints
13112 of the EX kind. */
13113
c0a91b2b 13114static const struct breakpoint_ops *
761269c8 13115ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
13116{
13117 switch (ex)
13118 {
761269c8 13119 case ada_catch_exception:
f7f9143b
JB
13120 return (&catch_exception_breakpoint_ops);
13121 break;
761269c8 13122 case ada_catch_exception_unhandled:
f7f9143b
JB
13123 return (&catch_exception_unhandled_breakpoint_ops);
13124 break;
761269c8 13125 case ada_catch_assert:
f7f9143b
JB
13126 return (&catch_assert_breakpoint_ops);
13127 break;
9f757bf7
XR
13128 case ada_catch_handlers:
13129 return (&catch_handlers_breakpoint_ops);
13130 break;
f7f9143b
JB
13131 default:
13132 internal_error (__FILE__, __LINE__,
13133 _("unexpected catchpoint kind (%d)"), ex);
13134 }
13135}
13136
13137/* Return the condition that will be used to match the current exception
13138 being raised with the exception that the user wants to catch. This
13139 assumes that this condition is used when the inferior just triggered
13140 an exception catchpoint.
cb7de75e 13141 EX: the type of catchpoints used for catching Ada exceptions. */
f7f9143b 13142
cb7de75e 13143static std::string
9f757bf7
XR
13144ada_exception_catchpoint_cond_string (const char *excep_string,
13145 enum ada_exception_catchpoint_kind ex)
f7f9143b 13146{
3d0b0fa3 13147 int i;
9f757bf7 13148 bool is_standard_exc = false;
cb7de75e 13149 std::string result;
9f757bf7
XR
13150
13151 if (ex == ada_catch_handlers)
13152 {
13153 /* For exception handlers catchpoints, the condition string does
13154 not use the same parameter as for the other exceptions. */
cb7de75e
TT
13155 result = ("long_integer (GNAT_GCC_exception_Access"
13156 "(gcc_exception).all.occurrence.id)");
9f757bf7
XR
13157 }
13158 else
cb7de75e 13159 result = "long_integer (e)";
3d0b0fa3 13160
0963b4bd 13161 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 13162 runtime units that have been compiled without debugging info; if
28010a5d 13163 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
13164 exception (e.g. "constraint_error") then, during the evaluation
13165 of the condition expression, the symbol lookup on this name would
0963b4bd 13166 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
13167 may then be set only on user-defined exceptions which have the
13168 same not-fully-qualified name (e.g. my_package.constraint_error).
13169
13170 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 13171 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
13172 exception constraint_error" is rewritten into "catch exception
13173 standard.constraint_error".
13174
13175 If an exception named contraint_error is defined in another package of
13176 the inferior program, then the only way to specify this exception as a
13177 breakpoint condition is to use its fully-qualified named:
13178 e.g. my_package.constraint_error. */
13179
13180 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13181 {
28010a5d 13182 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3 13183 {
9f757bf7
XR
13184 is_standard_exc = true;
13185 break;
3d0b0fa3
JB
13186 }
13187 }
9f757bf7 13188
cb7de75e
TT
13189 result += " = ";
13190
9f757bf7 13191 if (is_standard_exc)
cb7de75e 13192 string_appendf (result, "long_integer (&standard.%s)", excep_string);
9f757bf7 13193 else
cb7de75e 13194 string_appendf (result, "long_integer (&%s)", excep_string);
9f757bf7 13195
9f757bf7 13196 return result;
f7f9143b
JB
13197}
13198
13199/* Return the symtab_and_line that should be used to insert an exception
13200 catchpoint of the TYPE kind.
13201
28010a5d
PA
13202 ADDR_STRING returns the name of the function where the real
13203 breakpoint that implements the catchpoints is set, depending on the
13204 type of catchpoint we need to create. */
f7f9143b
JB
13205
13206static struct symtab_and_line
bc18fbb5 13207ada_exception_sal (enum ada_exception_catchpoint_kind ex,
f2fc3015 13208 const char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
13209{
13210 const char *sym_name;
13211 struct symbol *sym;
f7f9143b 13212
0259addd
JB
13213 /* First, find out which exception support info to use. */
13214 ada_exception_support_info_sniffer ();
13215
13216 /* Then lookup the function on which we will break in order to catch
f7f9143b 13217 the Ada exceptions requested by the user. */
f7f9143b
JB
13218 sym_name = ada_exception_sym_name (ex);
13219 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13220
57aff202
JB
13221 if (sym == NULL)
13222 error (_("Catchpoint symbol not found: %s"), sym_name);
13223
13224 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
13225 error (_("Unable to insert catchpoint. %s is not a function."), sym_name);
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}