]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
Remove cleanups from findcmd.c
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
61baf725 3 Copyright (C) 1992-2017 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"
0259addd 51#include "observer.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"
ccefe4c4 65
4c4b4cd2 66/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 67 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
68 Copied from valarith.c. */
69
70#ifndef TRUNCATION_TOWARDS_ZERO
71#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
72#endif
73
d2e4a39e 74static struct type *desc_base_type (struct type *);
14f9c5c9 75
d2e4a39e 76static struct type *desc_bounds_type (struct type *);
14f9c5c9 77
d2e4a39e 78static struct value *desc_bounds (struct value *);
14f9c5c9 79
d2e4a39e 80static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 81
d2e4a39e 82static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 83
556bdfd4 84static struct type *desc_data_target_type (struct type *);
14f9c5c9 85
d2e4a39e 86static struct value *desc_data (struct value *);
14f9c5c9 87
d2e4a39e 88static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 89
d2e4a39e 90static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 91
d2e4a39e 92static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 93
d2e4a39e 94static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 95
d2e4a39e 96static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 97
d2e4a39e 98static struct type *desc_index_type (struct type *, int);
14f9c5c9 99
d2e4a39e 100static int desc_arity (struct type *);
14f9c5c9 101
d2e4a39e 102static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 103
d2e4a39e 104static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 105
40658b94
PH
106static int full_match (const char *, const char *);
107
40bc484c 108static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 109
4c4b4cd2 110static void ada_add_block_symbols (struct obstack *,
f0c5f9b2 111 const struct block *, const char *,
2570f2b7 112 domain_enum, struct objfile *, int);
14f9c5c9 113
22cee43f
PMR
114static void ada_add_all_symbols (struct obstack *, const struct block *,
115 const char *, domain_enum, int, int *);
116
d12307c1 117static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 118
76a01679 119static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 120 const struct block *);
14f9c5c9 121
4c4b4cd2
PH
122static int num_defns_collected (struct obstack *);
123
d12307c1 124static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 125
4c4b4cd2 126static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 127 struct type *);
14f9c5c9 128
d2e4a39e 129static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 130 struct symbol *, const struct block *);
14f9c5c9 131
d2e4a39e 132static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 133
a121b7c1 134static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
135
136static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 137
d2e4a39e 138static int numeric_type_p (struct type *);
14f9c5c9 139
d2e4a39e 140static int integer_type_p (struct type *);
14f9c5c9 141
d2e4a39e 142static int scalar_type_p (struct type *);
14f9c5c9 143
d2e4a39e 144static int discrete_type_p (struct type *);
14f9c5c9 145
aeb5907d
JB
146static enum ada_renaming_category parse_old_style_renaming (struct type *,
147 const char **,
148 int *,
149 const char **);
150
151static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 152 const struct block *);
aeb5907d 153
a121b7c1 154static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
988f6b3d 155 int, int);
4c4b4cd2 156
d2e4a39e 157static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 158
b4ba55a1
JB
159static struct type *ada_find_parallel_type_with_name (struct type *,
160 const char *);
161
d2e4a39e 162static int is_dynamic_field (struct type *, int);
14f9c5c9 163
10a2c479 164static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 165 const gdb_byte *,
4c4b4cd2
PH
166 CORE_ADDR, struct value *);
167
168static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 169
28c85d6c 170static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 171
d2e4a39e 172static struct type *to_static_fixed_type (struct type *);
f192137b 173static struct type *static_unwrap_type (struct type *type);
14f9c5c9 174
d2e4a39e 175static struct value *unwrap_value (struct value *);
14f9c5c9 176
ad82864c 177static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 178
ad82864c 179static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 180
ad82864c
JB
181static long decode_packed_array_bitsize (struct type *);
182
183static struct value *decode_constrained_packed_array (struct value *);
184
185static int ada_is_packed_array_type (struct type *);
186
187static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 188
d2e4a39e 189static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 190 struct value **);
14f9c5c9 191
50810684 192static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 193
4c4b4cd2
PH
194static struct value *coerce_unspec_val_to_type (struct value *,
195 struct type *);
14f9c5c9 196
d2e4a39e 197static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 198
d2e4a39e 199static int equiv_types (struct type *, struct type *);
14f9c5c9 200
d2e4a39e 201static int is_name_suffix (const char *);
14f9c5c9 202
73589123
PH
203static int advance_wild_match (const char **, const char *, int);
204
205static int wild_match (const char *, const char *);
14f9c5c9 206
d2e4a39e 207static struct value *ada_coerce_ref (struct value *);
14f9c5c9 208
4c4b4cd2
PH
209static LONGEST pos_atr (struct value *);
210
3cb382c9 211static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 212
d2e4a39e 213static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 214
4c4b4cd2
PH
215static struct symbol *standard_lookup (const char *, const struct block *,
216 domain_enum);
14f9c5c9 217
108d56a4 218static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
219 struct type *);
220
221static struct value *ada_value_primitive_field (struct value *, int, int,
222 struct type *);
223
0d5cff50 224static int find_struct_field (const char *, struct type *, int,
52ce6436 225 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
226
227static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
228 struct value *);
229
d12307c1 230static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
231 struct value **, int, const char *,
232 struct type *);
233
4c4b4cd2
PH
234static int ada_is_direct_array_type (struct type *);
235
72d5681a
PH
236static void ada_language_arch_info (struct gdbarch *,
237 struct language_arch_info *);
714e53ab 238
52ce6436
PH
239static struct value *ada_index_struct_field (int, struct value *, int,
240 struct type *);
241
242static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
243 struct expression *,
244 int *, enum noside);
52ce6436
PH
245
246static void aggregate_assign_from_choices (struct value *, struct value *,
247 struct expression *,
248 int *, LONGEST *, int *,
249 int, LONGEST, LONGEST);
250
251static void aggregate_assign_positional (struct value *, struct value *,
252 struct expression *,
253 int *, LONGEST *, int *, int,
254 LONGEST, LONGEST);
255
256
257static void aggregate_assign_others (struct value *, struct value *,
258 struct expression *,
259 int *, LONGEST *, int, LONGEST, LONGEST);
260
261
262static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
263
264
265static struct value *ada_evaluate_subexp (struct type *, struct expression *,
266 int *, enum noside);
267
268static void ada_forward_operator_length (struct expression *, int, int *,
269 int *);
852dff6c
JB
270
271static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
272\f
273
ee01b665
JB
274/* The result of a symbol lookup to be stored in our symbol cache. */
275
276struct cache_entry
277{
278 /* The name used to perform the lookup. */
279 const char *name;
280 /* The namespace used during the lookup. */
fe978cb0 281 domain_enum domain;
ee01b665
JB
282 /* The symbol returned by the lookup, or NULL if no matching symbol
283 was found. */
284 struct symbol *sym;
285 /* The block where the symbol was found, or NULL if no matching
286 symbol was found. */
287 const struct block *block;
288 /* A pointer to the next entry with the same hash. */
289 struct cache_entry *next;
290};
291
292/* The Ada symbol cache, used to store the result of Ada-mode symbol
293 lookups in the course of executing the user's commands.
294
295 The cache is implemented using a simple, fixed-sized hash.
296 The size is fixed on the grounds that there are not likely to be
297 all that many symbols looked up during any given session, regardless
298 of the size of the symbol table. If we decide to go to a resizable
299 table, let's just use the stuff from libiberty instead. */
300
301#define HASH_SIZE 1009
302
303struct ada_symbol_cache
304{
305 /* An obstack used to store the entries in our cache. */
306 struct obstack cache_space;
307
308 /* The root of the hash table used to implement our symbol cache. */
309 struct cache_entry *root[HASH_SIZE];
310};
311
312static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 313
4c4b4cd2 314/* Maximum-sized dynamic type. */
14f9c5c9
AS
315static unsigned int varsize_limit;
316
67cb5b2d 317static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
318#ifdef VMS
319 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
320#else
14f9c5c9 321 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 322#endif
14f9c5c9 323
4c4b4cd2 324/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 325static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 326 = "__gnat_ada_main_program_name";
14f9c5c9 327
4c4b4cd2
PH
328/* Limit on the number of warnings to raise per expression evaluation. */
329static int warning_limit = 2;
330
331/* Number of warning messages issued; reset to 0 by cleanups after
332 expression evaluation. */
333static int warnings_issued = 0;
334
335static const char *known_runtime_file_name_patterns[] = {
336 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
337};
338
339static const char *known_auxiliary_function_name_patterns[] = {
340 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
341};
342
343/* Space for allocating results of ada_lookup_symbol_list. */
344static struct obstack symbol_list_obstack;
345
c6044dd1
JB
346/* Maintenance-related settings for this module. */
347
348static struct cmd_list_element *maint_set_ada_cmdlist;
349static struct cmd_list_element *maint_show_ada_cmdlist;
350
351/* Implement the "maintenance set ada" (prefix) command. */
352
353static void
354maint_set_ada_cmd (char *args, int from_tty)
355{
635c7e8a
TT
356 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
357 gdb_stdout);
c6044dd1
JB
358}
359
360/* Implement the "maintenance show ada" (prefix) command. */
361
362static void
363maint_show_ada_cmd (char *args, int from_tty)
364{
365 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
366}
367
368/* The "maintenance ada set/show ignore-descriptive-type" value. */
369
370static int ada_ignore_descriptive_types_p = 0;
371
e802dbe0
JB
372 /* Inferior-specific data. */
373
374/* Per-inferior data for this module. */
375
376struct ada_inferior_data
377{
378 /* The ada__tags__type_specific_data type, which is used when decoding
379 tagged types. With older versions of GNAT, this type was directly
380 accessible through a component ("tsd") in the object tag. But this
381 is no longer the case, so we cache it for each inferior. */
382 struct type *tsd_type;
3eecfa55
JB
383
384 /* The exception_support_info data. This data is used to determine
385 how to implement support for Ada exception catchpoints in a given
386 inferior. */
387 const struct exception_support_info *exception_info;
e802dbe0
JB
388};
389
390/* Our key to this module's inferior data. */
391static const struct inferior_data *ada_inferior_data;
392
393/* A cleanup routine for our inferior data. */
394static void
395ada_inferior_data_cleanup (struct inferior *inf, void *arg)
396{
397 struct ada_inferior_data *data;
398
9a3c8263 399 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
400 if (data != NULL)
401 xfree (data);
402}
403
404/* Return our inferior data for the given inferior (INF).
405
406 This function always returns a valid pointer to an allocated
407 ada_inferior_data structure. If INF's inferior data has not
408 been previously set, this functions creates a new one with all
409 fields set to zero, sets INF's inferior to it, and then returns
410 a pointer to that newly allocated ada_inferior_data. */
411
412static struct ada_inferior_data *
413get_ada_inferior_data (struct inferior *inf)
414{
415 struct ada_inferior_data *data;
416
9a3c8263 417 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
418 if (data == NULL)
419 {
41bf6aca 420 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
421 set_inferior_data (inf, ada_inferior_data, data);
422 }
423
424 return data;
425}
426
427/* Perform all necessary cleanups regarding our module's inferior data
428 that is required after the inferior INF just exited. */
429
430static void
431ada_inferior_exit (struct inferior *inf)
432{
433 ada_inferior_data_cleanup (inf, NULL);
434 set_inferior_data (inf, ada_inferior_data, NULL);
435}
436
ee01b665
JB
437
438 /* program-space-specific data. */
439
440/* This module's per-program-space data. */
441struct ada_pspace_data
442{
443 /* The Ada symbol cache. */
444 struct ada_symbol_cache *sym_cache;
445};
446
447/* Key to our per-program-space data. */
448static const struct program_space_data *ada_pspace_data_handle;
449
450/* Return this module's data for the given program space (PSPACE).
451 If not is found, add a zero'ed one now.
452
453 This function always returns a valid object. */
454
455static struct ada_pspace_data *
456get_ada_pspace_data (struct program_space *pspace)
457{
458 struct ada_pspace_data *data;
459
9a3c8263
SM
460 data = ((struct ada_pspace_data *)
461 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
462 if (data == NULL)
463 {
464 data = XCNEW (struct ada_pspace_data);
465 set_program_space_data (pspace, ada_pspace_data_handle, data);
466 }
467
468 return data;
469}
470
471/* The cleanup callback for this module's per-program-space data. */
472
473static void
474ada_pspace_data_cleanup (struct program_space *pspace, void *data)
475{
9a3c8263 476 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
477
478 if (pspace_data->sym_cache != NULL)
479 ada_free_symbol_cache (pspace_data->sym_cache);
480 xfree (pspace_data);
481}
482
4c4b4cd2
PH
483 /* Utilities */
484
720d1a40 485/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 486 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
487
488 Normally, we really expect a typedef type to only have 1 typedef layer.
489 In other words, we really expect the target type of a typedef type to be
490 a non-typedef type. This is particularly true for Ada units, because
491 the language does not have a typedef vs not-typedef distinction.
492 In that respect, the Ada compiler has been trying to eliminate as many
493 typedef definitions in the debugging information, since they generally
494 do not bring any extra information (we still use typedef under certain
495 circumstances related mostly to the GNAT encoding).
496
497 Unfortunately, we have seen situations where the debugging information
498 generated by the compiler leads to such multiple typedef layers. For
499 instance, consider the following example with stabs:
500
501 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
502 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
503
504 This is an error in the debugging information which causes type
505 pck__float_array___XUP to be defined twice, and the second time,
506 it is defined as a typedef of a typedef.
507
508 This is on the fringe of legality as far as debugging information is
509 concerned, and certainly unexpected. But it is easy to handle these
510 situations correctly, so we can afford to be lenient in this case. */
511
512static struct type *
513ada_typedef_target_type (struct type *type)
514{
515 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
516 type = TYPE_TARGET_TYPE (type);
517 return type;
518}
519
41d27058
JB
520/* Given DECODED_NAME a string holding a symbol name in its
521 decoded form (ie using the Ada dotted notation), returns
522 its unqualified name. */
523
524static const char *
525ada_unqualified_name (const char *decoded_name)
526{
2b0f535a
JB
527 const char *result;
528
529 /* If the decoded name starts with '<', it means that the encoded
530 name does not follow standard naming conventions, and thus that
531 it is not your typical Ada symbol name. Trying to unqualify it
532 is therefore pointless and possibly erroneous. */
533 if (decoded_name[0] == '<')
534 return decoded_name;
535
536 result = strrchr (decoded_name, '.');
41d27058
JB
537 if (result != NULL)
538 result++; /* Skip the dot... */
539 else
540 result = decoded_name;
541
542 return result;
543}
544
545/* Return a string starting with '<', followed by STR, and '>'.
546 The result is good until the next call. */
547
548static char *
549add_angle_brackets (const char *str)
550{
551 static char *result = NULL;
552
553 xfree (result);
88c15c34 554 result = xstrprintf ("<%s>", str);
41d27058
JB
555 return result;
556}
96d887e8 557
67cb5b2d 558static const char *
4c4b4cd2
PH
559ada_get_gdb_completer_word_break_characters (void)
560{
561 return ada_completer_word_break_characters;
562}
563
e79af960
JB
564/* Print an array element index using the Ada syntax. */
565
566static void
567ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 568 const struct value_print_options *options)
e79af960 569{
79a45b7d 570 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
571 fprintf_filtered (stream, " => ");
572}
573
f27cf670 574/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 575 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 576 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 577
f27cf670
AS
578void *
579grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 580{
d2e4a39e
AS
581 if (*size < min_size)
582 {
583 *size *= 2;
584 if (*size < min_size)
4c4b4cd2 585 *size = min_size;
f27cf670 586 vect = xrealloc (vect, *size * element_size);
d2e4a39e 587 }
f27cf670 588 return vect;
14f9c5c9
AS
589}
590
591/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 592 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
593
594static int
ebf56fd3 595field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
596{
597 int len = strlen (target);
5b4ee69b 598
d2e4a39e 599 return
4c4b4cd2
PH
600 (strncmp (field_name, target, len) == 0
601 && (field_name[len] == '\0'
61012eef 602 || (startswith (field_name + len, "___")
76a01679
JB
603 && strcmp (field_name + strlen (field_name) - 6,
604 "___XVN") != 0)));
14f9c5c9
AS
605}
606
607
872c8b51
JB
608/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
609 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
610 and return its index. This function also handles fields whose name
611 have ___ suffixes because the compiler sometimes alters their name
612 by adding such a suffix to represent fields with certain constraints.
613 If the field could not be found, return a negative number if
614 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
615
616int
617ada_get_field_index (const struct type *type, const char *field_name,
618 int maybe_missing)
619{
620 int fieldno;
872c8b51
JB
621 struct type *struct_type = check_typedef ((struct type *) type);
622
623 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
624 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
625 return fieldno;
626
627 if (!maybe_missing)
323e0a4a 628 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 629 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
630
631 return -1;
632}
633
634/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
635
636int
d2e4a39e 637ada_name_prefix_len (const char *name)
14f9c5c9
AS
638{
639 if (name == NULL)
640 return 0;
d2e4a39e 641 else
14f9c5c9 642 {
d2e4a39e 643 const char *p = strstr (name, "___");
5b4ee69b 644
14f9c5c9 645 if (p == NULL)
4c4b4cd2 646 return strlen (name);
14f9c5c9 647 else
4c4b4cd2 648 return p - name;
14f9c5c9
AS
649 }
650}
651
4c4b4cd2
PH
652/* Return non-zero if SUFFIX is a suffix of STR.
653 Return zero if STR is null. */
654
14f9c5c9 655static int
d2e4a39e 656is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
657{
658 int len1, len2;
5b4ee69b 659
14f9c5c9
AS
660 if (str == NULL)
661 return 0;
662 len1 = strlen (str);
663 len2 = strlen (suffix);
4c4b4cd2 664 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
665}
666
4c4b4cd2
PH
667/* The contents of value VAL, treated as a value of type TYPE. The
668 result is an lval in memory if VAL is. */
14f9c5c9 669
d2e4a39e 670static struct value *
4c4b4cd2 671coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 672{
61ee279c 673 type = ada_check_typedef (type);
df407dfe 674 if (value_type (val) == type)
4c4b4cd2 675 return val;
d2e4a39e 676 else
14f9c5c9 677 {
4c4b4cd2
PH
678 struct value *result;
679
680 /* Make sure that the object size is not unreasonable before
681 trying to allocate some memory for it. */
c1b5a1a6 682 ada_ensure_varsize_limit (type);
4c4b4cd2 683
41e8491f
JK
684 if (value_lazy (val)
685 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
686 result = allocate_value_lazy (type);
687 else
688 {
689 result = allocate_value (type);
9a0dc9e3 690 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 691 }
74bcbdf3 692 set_value_component_location (result, val);
9bbda503
AC
693 set_value_bitsize (result, value_bitsize (val));
694 set_value_bitpos (result, value_bitpos (val));
42ae5230 695 set_value_address (result, value_address (val));
14f9c5c9
AS
696 return result;
697 }
698}
699
fc1a4b47
AC
700static const gdb_byte *
701cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
702{
703 if (valaddr == NULL)
704 return NULL;
705 else
706 return valaddr + offset;
707}
708
709static CORE_ADDR
ebf56fd3 710cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
711{
712 if (address == 0)
713 return 0;
d2e4a39e 714 else
14f9c5c9
AS
715 return address + offset;
716}
717
4c4b4cd2
PH
718/* Issue a warning (as for the definition of warning in utils.c, but
719 with exactly one argument rather than ...), unless the limit on the
720 number of warnings has passed during the evaluation of the current
721 expression. */
a2249542 722
77109804
AC
723/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
724 provided by "complaint". */
a0b31db1 725static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 726
14f9c5c9 727static void
a2249542 728lim_warning (const char *format, ...)
14f9c5c9 729{
a2249542 730 va_list args;
a2249542 731
5b4ee69b 732 va_start (args, format);
4c4b4cd2
PH
733 warnings_issued += 1;
734 if (warnings_issued <= warning_limit)
a2249542
MK
735 vwarning (format, args);
736
737 va_end (args);
4c4b4cd2
PH
738}
739
714e53ab
PH
740/* Issue an error if the size of an object of type T is unreasonable,
741 i.e. if it would be a bad idea to allocate a value of this type in
742 GDB. */
743
c1b5a1a6
JB
744void
745ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
746{
747 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 748 error (_("object size is larger than varsize-limit"));
714e53ab
PH
749}
750
0963b4bd 751/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 752static LONGEST
c3e5cd34 753max_of_size (int size)
4c4b4cd2 754{
76a01679 755 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 756
76a01679 757 return top_bit | (top_bit - 1);
4c4b4cd2
PH
758}
759
0963b4bd 760/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 761static LONGEST
c3e5cd34 762min_of_size (int size)
4c4b4cd2 763{
c3e5cd34 764 return -max_of_size (size) - 1;
4c4b4cd2
PH
765}
766
0963b4bd 767/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 768static ULONGEST
c3e5cd34 769umax_of_size (int size)
4c4b4cd2 770{
76a01679 771 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 772
76a01679 773 return top_bit | (top_bit - 1);
4c4b4cd2
PH
774}
775
0963b4bd 776/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
777static LONGEST
778max_of_type (struct type *t)
4c4b4cd2 779{
c3e5cd34
PH
780 if (TYPE_UNSIGNED (t))
781 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
782 else
783 return max_of_size (TYPE_LENGTH (t));
784}
785
0963b4bd 786/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
787static LONGEST
788min_of_type (struct type *t)
789{
790 if (TYPE_UNSIGNED (t))
791 return 0;
792 else
793 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
794}
795
796/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
797LONGEST
798ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 799{
c3345124 800 type = resolve_dynamic_type (type, NULL, 0);
76a01679 801 switch (TYPE_CODE (type))
4c4b4cd2
PH
802 {
803 case TYPE_CODE_RANGE:
690cc4eb 804 return TYPE_HIGH_BOUND (type);
4c4b4cd2 805 case TYPE_CODE_ENUM:
14e75d8e 806 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
807 case TYPE_CODE_BOOL:
808 return 1;
809 case TYPE_CODE_CHAR:
76a01679 810 case TYPE_CODE_INT:
690cc4eb 811 return max_of_type (type);
4c4b4cd2 812 default:
43bbcdc2 813 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
814 }
815}
816
14e75d8e 817/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
818LONGEST
819ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 820{
c3345124 821 type = resolve_dynamic_type (type, NULL, 0);
76a01679 822 switch (TYPE_CODE (type))
4c4b4cd2
PH
823 {
824 case TYPE_CODE_RANGE:
690cc4eb 825 return TYPE_LOW_BOUND (type);
4c4b4cd2 826 case TYPE_CODE_ENUM:
14e75d8e 827 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
828 case TYPE_CODE_BOOL:
829 return 0;
830 case TYPE_CODE_CHAR:
76a01679 831 case TYPE_CODE_INT:
690cc4eb 832 return min_of_type (type);
4c4b4cd2 833 default:
43bbcdc2 834 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
835 }
836}
837
838/* The identity on non-range types. For range types, the underlying
76a01679 839 non-range scalar type. */
4c4b4cd2
PH
840
841static struct type *
18af8284 842get_base_type (struct type *type)
4c4b4cd2
PH
843{
844 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
845 {
76a01679
JB
846 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
847 return type;
4c4b4cd2
PH
848 type = TYPE_TARGET_TYPE (type);
849 }
850 return type;
14f9c5c9 851}
41246937
JB
852
853/* Return a decoded version of the given VALUE. This means returning
854 a value whose type is obtained by applying all the GNAT-specific
855 encondings, making the resulting type a static but standard description
856 of the initial type. */
857
858struct value *
859ada_get_decoded_value (struct value *value)
860{
861 struct type *type = ada_check_typedef (value_type (value));
862
863 if (ada_is_array_descriptor_type (type)
864 || (ada_is_constrained_packed_array_type (type)
865 && TYPE_CODE (type) != TYPE_CODE_PTR))
866 {
867 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
868 value = ada_coerce_to_simple_array_ptr (value);
869 else
870 value = ada_coerce_to_simple_array (value);
871 }
872 else
873 value = ada_to_fixed_value (value);
874
875 return value;
876}
877
878/* Same as ada_get_decoded_value, but with the given TYPE.
879 Because there is no associated actual value for this type,
880 the resulting type might be a best-effort approximation in
881 the case of dynamic types. */
882
883struct type *
884ada_get_decoded_type (struct type *type)
885{
886 type = to_static_fixed_type (type);
887 if (ada_is_constrained_packed_array_type (type))
888 type = ada_coerce_to_simple_array_type (type);
889 return type;
890}
891
4c4b4cd2 892\f
76a01679 893
4c4b4cd2 894 /* Language Selection */
14f9c5c9
AS
895
896/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 897 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 898
14f9c5c9 899enum language
ccefe4c4 900ada_update_initial_language (enum language lang)
14f9c5c9 901{
d2e4a39e 902 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 903 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 904 return language_ada;
14f9c5c9
AS
905
906 return lang;
907}
96d887e8
PH
908
909/* If the main procedure is written in Ada, then return its name.
910 The result is good until the next call. Return NULL if the main
911 procedure doesn't appear to be in Ada. */
912
913char *
914ada_main_name (void)
915{
3b7344d5 916 struct bound_minimal_symbol msym;
f9bc20b9 917 static char *main_program_name = NULL;
6c038f32 918
96d887e8
PH
919 /* For Ada, the name of the main procedure is stored in a specific
920 string constant, generated by the binder. Look for that symbol,
921 extract its address, and then read that string. If we didn't find
922 that string, then most probably the main procedure is not written
923 in Ada. */
924 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
925
3b7344d5 926 if (msym.minsym != NULL)
96d887e8 927 {
f9bc20b9
JB
928 CORE_ADDR main_program_name_addr;
929 int err_code;
930
77e371c0 931 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 932 if (main_program_name_addr == 0)
323e0a4a 933 error (_("Invalid address for Ada main program name."));
96d887e8 934
f9bc20b9
JB
935 xfree (main_program_name);
936 target_read_string (main_program_name_addr, &main_program_name,
937 1024, &err_code);
938
939 if (err_code != 0)
940 return NULL;
96d887e8
PH
941 return main_program_name;
942 }
943
944 /* The main procedure doesn't seem to be in Ada. */
945 return NULL;
946}
14f9c5c9 947\f
4c4b4cd2 948 /* Symbols */
d2e4a39e 949
4c4b4cd2
PH
950/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
951 of NULLs. */
14f9c5c9 952
d2e4a39e
AS
953const struct ada_opname_map ada_opname_table[] = {
954 {"Oadd", "\"+\"", BINOP_ADD},
955 {"Osubtract", "\"-\"", BINOP_SUB},
956 {"Omultiply", "\"*\"", BINOP_MUL},
957 {"Odivide", "\"/\"", BINOP_DIV},
958 {"Omod", "\"mod\"", BINOP_MOD},
959 {"Orem", "\"rem\"", BINOP_REM},
960 {"Oexpon", "\"**\"", BINOP_EXP},
961 {"Olt", "\"<\"", BINOP_LESS},
962 {"Ole", "\"<=\"", BINOP_LEQ},
963 {"Ogt", "\">\"", BINOP_GTR},
964 {"Oge", "\">=\"", BINOP_GEQ},
965 {"Oeq", "\"=\"", BINOP_EQUAL},
966 {"One", "\"/=\"", BINOP_NOTEQUAL},
967 {"Oand", "\"and\"", BINOP_BITWISE_AND},
968 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
969 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
970 {"Oconcat", "\"&\"", BINOP_CONCAT},
971 {"Oabs", "\"abs\"", UNOP_ABS},
972 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
973 {"Oadd", "\"+\"", UNOP_PLUS},
974 {"Osubtract", "\"-\"", UNOP_NEG},
975 {NULL, NULL}
14f9c5c9
AS
976};
977
4c4b4cd2
PH
978/* The "encoded" form of DECODED, according to GNAT conventions.
979 The result is valid until the next call to ada_encode. */
980
14f9c5c9 981char *
4c4b4cd2 982ada_encode (const char *decoded)
14f9c5c9 983{
4c4b4cd2
PH
984 static char *encoding_buffer = NULL;
985 static size_t encoding_buffer_size = 0;
d2e4a39e 986 const char *p;
14f9c5c9 987 int k;
d2e4a39e 988
4c4b4cd2 989 if (decoded == NULL)
14f9c5c9
AS
990 return NULL;
991
4c4b4cd2
PH
992 GROW_VECT (encoding_buffer, encoding_buffer_size,
993 2 * strlen (decoded) + 10);
14f9c5c9
AS
994
995 k = 0;
4c4b4cd2 996 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 997 {
cdc7bb92 998 if (*p == '.')
4c4b4cd2
PH
999 {
1000 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1001 k += 2;
1002 }
14f9c5c9 1003 else if (*p == '"')
4c4b4cd2
PH
1004 {
1005 const struct ada_opname_map *mapping;
1006
1007 for (mapping = ada_opname_table;
1265e4aa 1008 mapping->encoded != NULL
61012eef 1009 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1010 ;
1011 if (mapping->encoded == NULL)
323e0a4a 1012 error (_("invalid Ada operator name: %s"), p);
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
1028/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1029 quotes, unfolded, but with the quotes stripped away. Result good
1030 to next call. */
1031
d2e4a39e
AS
1032char *
1033ada_fold_name (const char *name)
14f9c5c9 1034{
d2e4a39e 1035 static char *fold_buffer = NULL;
14f9c5c9
AS
1036 static size_t fold_buffer_size = 0;
1037
1038 int len = strlen (name);
d2e4a39e 1039 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1040
1041 if (name[0] == '\'')
1042 {
d2e4a39e
AS
1043 strncpy (fold_buffer, name + 1, len - 2);
1044 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1045 }
1046 else
1047 {
1048 int i;
5b4ee69b 1049
14f9c5c9 1050 for (i = 0; i <= len; i += 1)
4c4b4cd2 1051 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1052 }
1053
1054 return fold_buffer;
1055}
1056
529cad9c
PH
1057/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1058
1059static int
1060is_lower_alphanum (const char c)
1061{
1062 return (isdigit (c) || (isalpha (c) && islower (c)));
1063}
1064
c90092fe
JB
1065/* ENCODED is the linkage name of a symbol and LEN contains its length.
1066 This function saves in LEN the length of that same symbol name but
1067 without either of these suffixes:
29480c32
JB
1068 . .{DIGIT}+
1069 . ${DIGIT}+
1070 . ___{DIGIT}+
1071 . __{DIGIT}+.
c90092fe 1072
29480c32
JB
1073 These are suffixes introduced by the compiler for entities such as
1074 nested subprogram for instance, in order to avoid name clashes.
1075 They do not serve any purpose for the debugger. */
1076
1077static void
1078ada_remove_trailing_digits (const char *encoded, int *len)
1079{
1080 if (*len > 1 && isdigit (encoded[*len - 1]))
1081 {
1082 int i = *len - 2;
5b4ee69b 1083
29480c32
JB
1084 while (i > 0 && isdigit (encoded[i]))
1085 i--;
1086 if (i >= 0 && encoded[i] == '.')
1087 *len = i;
1088 else if (i >= 0 && encoded[i] == '$')
1089 *len = i;
61012eef 1090 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1091 *len = i - 2;
61012eef 1092 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1093 *len = i - 1;
1094 }
1095}
1096
1097/* Remove the suffix introduced by the compiler for protected object
1098 subprograms. */
1099
1100static void
1101ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1102{
1103 /* Remove trailing N. */
1104
1105 /* Protected entry subprograms are broken into two
1106 separate subprograms: The first one is unprotected, and has
1107 a 'N' suffix; the second is the protected version, and has
0963b4bd 1108 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1109 the protection. Since the P subprograms are internally generated,
1110 we leave these names undecoded, giving the user a clue that this
1111 entity is internal. */
1112
1113 if (*len > 1
1114 && encoded[*len - 1] == 'N'
1115 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1116 *len = *len - 1;
1117}
1118
69fadcdf
JB
1119/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1120
1121static void
1122ada_remove_Xbn_suffix (const char *encoded, int *len)
1123{
1124 int i = *len - 1;
1125
1126 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1127 i--;
1128
1129 if (encoded[i] != 'X')
1130 return;
1131
1132 if (i == 0)
1133 return;
1134
1135 if (isalnum (encoded[i-1]))
1136 *len = i;
1137}
1138
29480c32
JB
1139/* If ENCODED follows the GNAT entity encoding conventions, then return
1140 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1141 replaced by ENCODED.
14f9c5c9 1142
4c4b4cd2 1143 The resulting string is valid until the next call of ada_decode.
29480c32 1144 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1145 is returned. */
1146
1147const char *
1148ada_decode (const char *encoded)
14f9c5c9
AS
1149{
1150 int i, j;
1151 int len0;
d2e4a39e 1152 const char *p;
4c4b4cd2 1153 char *decoded;
14f9c5c9 1154 int at_start_name;
4c4b4cd2
PH
1155 static char *decoding_buffer = NULL;
1156 static size_t decoding_buffer_size = 0;
d2e4a39e 1157
29480c32
JB
1158 /* The name of the Ada main procedure starts with "_ada_".
1159 This prefix is not part of the decoded name, so skip this part
1160 if we see this prefix. */
61012eef 1161 if (startswith (encoded, "_ada_"))
4c4b4cd2 1162 encoded += 5;
14f9c5c9 1163
29480c32
JB
1164 /* If the name starts with '_', then it is not a properly encoded
1165 name, so do not attempt to decode it. Similarly, if the name
1166 starts with '<', the name should not be decoded. */
4c4b4cd2 1167 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1168 goto Suppress;
1169
4c4b4cd2 1170 len0 = strlen (encoded);
4c4b4cd2 1171
29480c32
JB
1172 ada_remove_trailing_digits (encoded, &len0);
1173 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1174
4c4b4cd2
PH
1175 /* Remove the ___X.* suffix if present. Do not forget to verify that
1176 the suffix is located before the current "end" of ENCODED. We want
1177 to avoid re-matching parts of ENCODED that have previously been
1178 marked as discarded (by decrementing LEN0). */
1179 p = strstr (encoded, "___");
1180 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1181 {
1182 if (p[3] == 'X')
4c4b4cd2 1183 len0 = p - encoded;
14f9c5c9 1184 else
4c4b4cd2 1185 goto Suppress;
14f9c5c9 1186 }
4c4b4cd2 1187
29480c32
JB
1188 /* Remove any trailing TKB suffix. It tells us that this symbol
1189 is for the body of a task, but that information does not actually
1190 appear in the decoded name. */
1191
61012eef 1192 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1193 len0 -= 3;
76a01679 1194
a10967fa
JB
1195 /* Remove any trailing TB suffix. The TB suffix is slightly different
1196 from the TKB suffix because it is used for non-anonymous task
1197 bodies. */
1198
61012eef 1199 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1200 len0 -= 2;
1201
29480c32
JB
1202 /* Remove trailing "B" suffixes. */
1203 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1204
61012eef 1205 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1206 len0 -= 1;
1207
4c4b4cd2 1208 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1209
4c4b4cd2
PH
1210 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1211 decoded = decoding_buffer;
14f9c5c9 1212
29480c32
JB
1213 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1214
4c4b4cd2 1215 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1216 {
4c4b4cd2
PH
1217 i = len0 - 2;
1218 while ((i >= 0 && isdigit (encoded[i]))
1219 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1220 i -= 1;
1221 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1222 len0 = i - 1;
1223 else if (encoded[i] == '$')
1224 len0 = i;
d2e4a39e 1225 }
14f9c5c9 1226
29480c32
JB
1227 /* The first few characters that are not alphabetic are not part
1228 of any encoding we use, so we can copy them over verbatim. */
1229
4c4b4cd2
PH
1230 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1231 decoded[j] = encoded[i];
14f9c5c9
AS
1232
1233 at_start_name = 1;
1234 while (i < len0)
1235 {
29480c32 1236 /* Is this a symbol function? */
4c4b4cd2
PH
1237 if (at_start_name && encoded[i] == 'O')
1238 {
1239 int k;
5b4ee69b 1240
4c4b4cd2
PH
1241 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1242 {
1243 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1244 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1245 op_len - 1) == 0)
1246 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1247 {
1248 strcpy (decoded + j, ada_opname_table[k].decoded);
1249 at_start_name = 0;
1250 i += op_len;
1251 j += strlen (ada_opname_table[k].decoded);
1252 break;
1253 }
1254 }
1255 if (ada_opname_table[k].encoded != NULL)
1256 continue;
1257 }
14f9c5c9
AS
1258 at_start_name = 0;
1259
529cad9c
PH
1260 /* Replace "TK__" with "__", which will eventually be translated
1261 into "." (just below). */
1262
61012eef 1263 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1264 i += 2;
529cad9c 1265
29480c32
JB
1266 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1267 be translated into "." (just below). These are internal names
1268 generated for anonymous blocks inside which our symbol is nested. */
1269
1270 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1271 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1272 && isdigit (encoded [i+4]))
1273 {
1274 int k = i + 5;
1275
1276 while (k < len0 && isdigit (encoded[k]))
1277 k++; /* Skip any extra digit. */
1278
1279 /* Double-check that the "__B_{DIGITS}+" sequence we found
1280 is indeed followed by "__". */
1281 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1282 i = k;
1283 }
1284
529cad9c
PH
1285 /* Remove _E{DIGITS}+[sb] */
1286
1287 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1288 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1289 one implements the actual entry code, and has a suffix following
1290 the convention above; the second one implements the barrier and
1291 uses the same convention as above, except that the 'E' is replaced
1292 by a 'B'.
1293
1294 Just as above, we do not decode the name of barrier functions
1295 to give the user a clue that the code he is debugging has been
1296 internally generated. */
1297
1298 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1299 && isdigit (encoded[i+2]))
1300 {
1301 int k = i + 3;
1302
1303 while (k < len0 && isdigit (encoded[k]))
1304 k++;
1305
1306 if (k < len0
1307 && (encoded[k] == 'b' || encoded[k] == 's'))
1308 {
1309 k++;
1310 /* Just as an extra precaution, make sure that if this
1311 suffix is followed by anything else, it is a '_'.
1312 Otherwise, we matched this sequence by accident. */
1313 if (k == len0
1314 || (k < len0 && encoded[k] == '_'))
1315 i = k;
1316 }
1317 }
1318
1319 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1320 the GNAT front-end in protected object subprograms. */
1321
1322 if (i < len0 + 3
1323 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1324 {
1325 /* Backtrack a bit up until we reach either the begining of
1326 the encoded name, or "__". Make sure that we only find
1327 digits or lowercase characters. */
1328 const char *ptr = encoded + i - 1;
1329
1330 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1331 ptr--;
1332 if (ptr < encoded
1333 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1334 i++;
1335 }
1336
4c4b4cd2
PH
1337 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1338 {
29480c32
JB
1339 /* This is a X[bn]* sequence not separated from the previous
1340 part of the name with a non-alpha-numeric character (in other
1341 words, immediately following an alpha-numeric character), then
1342 verify that it is placed at the end of the encoded name. If
1343 not, then the encoding is not valid and we should abort the
1344 decoding. Otherwise, just skip it, it is used in body-nested
1345 package names. */
4c4b4cd2
PH
1346 do
1347 i += 1;
1348 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1349 if (i < len0)
1350 goto Suppress;
1351 }
cdc7bb92 1352 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1353 {
29480c32 1354 /* Replace '__' by '.'. */
4c4b4cd2
PH
1355 decoded[j] = '.';
1356 at_start_name = 1;
1357 i += 2;
1358 j += 1;
1359 }
14f9c5c9 1360 else
4c4b4cd2 1361 {
29480c32
JB
1362 /* It's a character part of the decoded name, so just copy it
1363 over. */
4c4b4cd2
PH
1364 decoded[j] = encoded[i];
1365 i += 1;
1366 j += 1;
1367 }
14f9c5c9 1368 }
4c4b4cd2 1369 decoded[j] = '\000';
14f9c5c9 1370
29480c32
JB
1371 /* Decoded names should never contain any uppercase character.
1372 Double-check this, and abort the decoding if we find one. */
1373
4c4b4cd2
PH
1374 for (i = 0; decoded[i] != '\0'; i += 1)
1375 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1376 goto Suppress;
1377
4c4b4cd2
PH
1378 if (strcmp (decoded, encoded) == 0)
1379 return encoded;
1380 else
1381 return decoded;
14f9c5c9
AS
1382
1383Suppress:
4c4b4cd2
PH
1384 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1385 decoded = decoding_buffer;
1386 if (encoded[0] == '<')
1387 strcpy (decoded, encoded);
14f9c5c9 1388 else
88c15c34 1389 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1390 return decoded;
1391
1392}
1393
1394/* Table for keeping permanent unique copies of decoded names. Once
1395 allocated, names in this table are never released. While this is a
1396 storage leak, it should not be significant unless there are massive
1397 changes in the set of decoded names in successive versions of a
1398 symbol table loaded during a single session. */
1399static struct htab *decoded_names_store;
1400
1401/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1402 in the language-specific part of GSYMBOL, if it has not been
1403 previously computed. Tries to save the decoded name in the same
1404 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1405 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1406 GSYMBOL).
4c4b4cd2
PH
1407 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1408 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1409 when a decoded name is cached in it. */
4c4b4cd2 1410
45e6c716 1411const char *
f85f34ed 1412ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1413{
f85f34ed
TT
1414 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1415 const char **resultp =
615b3f62 1416 &gsymbol->language_specific.demangled_name;
5b4ee69b 1417
f85f34ed 1418 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1419 {
1420 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1421 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1422
f85f34ed 1423 gsymbol->ada_mangled = 1;
5b4ee69b 1424
f85f34ed 1425 if (obstack != NULL)
224c3ddb
SM
1426 *resultp
1427 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1428 else
76a01679 1429 {
f85f34ed
TT
1430 /* Sometimes, we can't find a corresponding objfile, in
1431 which case, we put the result on the heap. Since we only
1432 decode when needed, we hope this usually does not cause a
1433 significant memory leak (FIXME). */
1434
76a01679
JB
1435 char **slot = (char **) htab_find_slot (decoded_names_store,
1436 decoded, INSERT);
5b4ee69b 1437
76a01679
JB
1438 if (*slot == NULL)
1439 *slot = xstrdup (decoded);
1440 *resultp = *slot;
1441 }
4c4b4cd2 1442 }
14f9c5c9 1443
4c4b4cd2
PH
1444 return *resultp;
1445}
76a01679 1446
2c0b251b 1447static char *
76a01679 1448ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1449{
1450 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1451}
1452
8b302db8
TT
1453/* Implement la_sniff_from_mangled_name for Ada. */
1454
1455static int
1456ada_sniff_from_mangled_name (const char *mangled, char **out)
1457{
1458 const char *demangled = ada_decode (mangled);
1459
1460 *out = NULL;
1461
1462 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1463 {
1464 /* Set the gsymbol language to Ada, but still return 0.
1465 Two reasons for that:
1466
1467 1. For Ada, we prefer computing the symbol's decoded name
1468 on the fly rather than pre-compute it, in order to save
1469 memory (Ada projects are typically very large).
1470
1471 2. There are some areas in the definition of the GNAT
1472 encoding where, with a bit of bad luck, we might be able
1473 to decode a non-Ada symbol, generating an incorrect
1474 demangled name (Eg: names ending with "TB" for instance
1475 are identified as task bodies and so stripped from
1476 the decoded name returned).
1477
1478 Returning 1, here, but not setting *DEMANGLED, helps us get a
1479 little bit of the best of both worlds. Because we're last,
1480 we should not affect any of the other languages that were
1481 able to demangle the symbol before us; we get to correctly
1482 tag Ada symbols as such; and even if we incorrectly tagged a
1483 non-Ada symbol, which should be rare, any routing through the
1484 Ada language should be transparent (Ada tries to behave much
1485 like C/C++ with non-Ada symbols). */
1486 return 1;
1487 }
1488
1489 return 0;
1490}
1491
14f9c5c9 1492/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1493 suffixes that encode debugging information or leading _ada_ on
1494 SYM_NAME (see is_name_suffix commentary for the debugging
1495 information that is ignored). If WILD, then NAME need only match a
1496 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1497 either argument is NULL. */
14f9c5c9 1498
2c0b251b 1499static int
40658b94 1500match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1501{
1502 if (sym_name == NULL || name == NULL)
1503 return 0;
1504 else if (wild)
73589123 1505 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1506 else
1507 {
1508 int len_name = strlen (name);
5b4ee69b 1509
4c4b4cd2
PH
1510 return (strncmp (sym_name, name, len_name) == 0
1511 && is_name_suffix (sym_name + len_name))
61012eef 1512 || (startswith (sym_name, "_ada_")
4c4b4cd2
PH
1513 && strncmp (sym_name + 5, name, len_name) == 0
1514 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1515 }
14f9c5c9 1516}
14f9c5c9 1517\f
d2e4a39e 1518
4c4b4cd2 1519 /* Arrays */
14f9c5c9 1520
28c85d6c
JB
1521/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1522 generated by the GNAT compiler to describe the index type used
1523 for each dimension of an array, check whether it follows the latest
1524 known encoding. If not, fix it up to conform to the latest encoding.
1525 Otherwise, do nothing. This function also does nothing if
1526 INDEX_DESC_TYPE is NULL.
1527
1528 The GNAT encoding used to describle the array index type evolved a bit.
1529 Initially, the information would be provided through the name of each
1530 field of the structure type only, while the type of these fields was
1531 described as unspecified and irrelevant. The debugger was then expected
1532 to perform a global type lookup using the name of that field in order
1533 to get access to the full index type description. Because these global
1534 lookups can be very expensive, the encoding was later enhanced to make
1535 the global lookup unnecessary by defining the field type as being
1536 the full index type description.
1537
1538 The purpose of this routine is to allow us to support older versions
1539 of the compiler by detecting the use of the older encoding, and by
1540 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1541 we essentially replace each field's meaningless type by the associated
1542 index subtype). */
1543
1544void
1545ada_fixup_array_indexes_type (struct type *index_desc_type)
1546{
1547 int i;
1548
1549 if (index_desc_type == NULL)
1550 return;
1551 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1552
1553 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1554 to check one field only, no need to check them all). If not, return
1555 now.
1556
1557 If our INDEX_DESC_TYPE was generated using the older encoding,
1558 the field type should be a meaningless integer type whose name
1559 is not equal to the field name. */
1560 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1561 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1562 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1563 return;
1564
1565 /* Fixup each field of INDEX_DESC_TYPE. */
1566 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1567 {
0d5cff50 1568 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1569 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1570
1571 if (raw_type)
1572 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1573 }
1574}
1575
4c4b4cd2 1576/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1577
a121b7c1 1578static const char *bound_name[] = {
d2e4a39e 1579 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1580 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1581};
1582
1583/* Maximum number of array dimensions we are prepared to handle. */
1584
4c4b4cd2 1585#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1586
14f9c5c9 1587
4c4b4cd2
PH
1588/* The desc_* routines return primitive portions of array descriptors
1589 (fat pointers). */
14f9c5c9
AS
1590
1591/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1592 level of indirection, if needed. */
1593
d2e4a39e
AS
1594static struct type *
1595desc_base_type (struct type *type)
14f9c5c9
AS
1596{
1597 if (type == NULL)
1598 return NULL;
61ee279c 1599 type = ada_check_typedef (type);
720d1a40
JB
1600 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1601 type = ada_typedef_target_type (type);
1602
1265e4aa
JB
1603 if (type != NULL
1604 && (TYPE_CODE (type) == TYPE_CODE_PTR
1605 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1606 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1607 else
1608 return type;
1609}
1610
4c4b4cd2
PH
1611/* True iff TYPE indicates a "thin" array pointer type. */
1612
14f9c5c9 1613static int
d2e4a39e 1614is_thin_pntr (struct type *type)
14f9c5c9 1615{
d2e4a39e 1616 return
14f9c5c9
AS
1617 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1618 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1619}
1620
4c4b4cd2
PH
1621/* The descriptor type for thin pointer type TYPE. */
1622
d2e4a39e
AS
1623static struct type *
1624thin_descriptor_type (struct type *type)
14f9c5c9 1625{
d2e4a39e 1626 struct type *base_type = desc_base_type (type);
5b4ee69b 1627
14f9c5c9
AS
1628 if (base_type == NULL)
1629 return NULL;
1630 if (is_suffix (ada_type_name (base_type), "___XVE"))
1631 return base_type;
d2e4a39e 1632 else
14f9c5c9 1633 {
d2e4a39e 1634 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1635
14f9c5c9 1636 if (alt_type == NULL)
4c4b4cd2 1637 return base_type;
14f9c5c9 1638 else
4c4b4cd2 1639 return alt_type;
14f9c5c9
AS
1640 }
1641}
1642
4c4b4cd2
PH
1643/* A pointer to the array data for thin-pointer value VAL. */
1644
d2e4a39e
AS
1645static struct value *
1646thin_data_pntr (struct value *val)
14f9c5c9 1647{
828292f2 1648 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1649 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1650
556bdfd4
UW
1651 data_type = lookup_pointer_type (data_type);
1652
14f9c5c9 1653 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1654 return value_cast (data_type, value_copy (val));
d2e4a39e 1655 else
42ae5230 1656 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1657}
1658
4c4b4cd2
PH
1659/* True iff TYPE indicates a "thick" array pointer type. */
1660
14f9c5c9 1661static int
d2e4a39e 1662is_thick_pntr (struct type *type)
14f9c5c9
AS
1663{
1664 type = desc_base_type (type);
1665 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1666 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1667}
1668
4c4b4cd2
PH
1669/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1670 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1671
d2e4a39e
AS
1672static struct type *
1673desc_bounds_type (struct type *type)
14f9c5c9 1674{
d2e4a39e 1675 struct type *r;
14f9c5c9
AS
1676
1677 type = desc_base_type (type);
1678
1679 if (type == NULL)
1680 return NULL;
1681 else if (is_thin_pntr (type))
1682 {
1683 type = thin_descriptor_type (type);
1684 if (type == NULL)
4c4b4cd2 1685 return NULL;
14f9c5c9
AS
1686 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1687 if (r != NULL)
61ee279c 1688 return ada_check_typedef (r);
14f9c5c9
AS
1689 }
1690 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1691 {
1692 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1693 if (r != NULL)
61ee279c 1694 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1695 }
1696 return NULL;
1697}
1698
1699/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1700 one, a pointer to its bounds data. Otherwise NULL. */
1701
d2e4a39e
AS
1702static struct value *
1703desc_bounds (struct value *arr)
14f9c5c9 1704{
df407dfe 1705 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1706
d2e4a39e 1707 if (is_thin_pntr (type))
14f9c5c9 1708 {
d2e4a39e 1709 struct type *bounds_type =
4c4b4cd2 1710 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1711 LONGEST addr;
1712
4cdfadb1 1713 if (bounds_type == NULL)
323e0a4a 1714 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1715
1716 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1717 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1718 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1719 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1720 addr = value_as_long (arr);
d2e4a39e 1721 else
42ae5230 1722 addr = value_address (arr);
14f9c5c9 1723
d2e4a39e 1724 return
4c4b4cd2
PH
1725 value_from_longest (lookup_pointer_type (bounds_type),
1726 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1727 }
1728
1729 else if (is_thick_pntr (type))
05e522ef
JB
1730 {
1731 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1732 _("Bad GNAT array descriptor"));
1733 struct type *p_bounds_type = value_type (p_bounds);
1734
1735 if (p_bounds_type
1736 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1737 {
1738 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1739
1740 if (TYPE_STUB (target_type))
1741 p_bounds = value_cast (lookup_pointer_type
1742 (ada_check_typedef (target_type)),
1743 p_bounds);
1744 }
1745 else
1746 error (_("Bad GNAT array descriptor"));
1747
1748 return p_bounds;
1749 }
14f9c5c9
AS
1750 else
1751 return NULL;
1752}
1753
4c4b4cd2
PH
1754/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1755 position of the field containing the address of the bounds data. */
1756
14f9c5c9 1757static int
d2e4a39e 1758fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1759{
1760 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1761}
1762
1763/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1764 size of the field containing the address of the bounds data. */
1765
14f9c5c9 1766static int
d2e4a39e 1767fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1768{
1769 type = desc_base_type (type);
1770
d2e4a39e 1771 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1772 return TYPE_FIELD_BITSIZE (type, 1);
1773 else
61ee279c 1774 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1775}
1776
4c4b4cd2 1777/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1778 pointer to one, the type of its array data (a array-with-no-bounds type);
1779 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1780 data. */
4c4b4cd2 1781
d2e4a39e 1782static struct type *
556bdfd4 1783desc_data_target_type (struct type *type)
14f9c5c9
AS
1784{
1785 type = desc_base_type (type);
1786
4c4b4cd2 1787 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1788 if (is_thin_pntr (type))
556bdfd4 1789 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1790 else if (is_thick_pntr (type))
556bdfd4
UW
1791 {
1792 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1793
1794 if (data_type
1795 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1796 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1797 }
1798
1799 return NULL;
14f9c5c9
AS
1800}
1801
1802/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1803 its array data. */
4c4b4cd2 1804
d2e4a39e
AS
1805static struct value *
1806desc_data (struct value *arr)
14f9c5c9 1807{
df407dfe 1808 struct type *type = value_type (arr);
5b4ee69b 1809
14f9c5c9
AS
1810 if (is_thin_pntr (type))
1811 return thin_data_pntr (arr);
1812 else if (is_thick_pntr (type))
d2e4a39e 1813 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1814 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1815 else
1816 return NULL;
1817}
1818
1819
1820/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1821 position of the field containing the address of the data. */
1822
14f9c5c9 1823static int
d2e4a39e 1824fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1825{
1826 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1827}
1828
1829/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1830 size of the field containing the address of the data. */
1831
14f9c5c9 1832static int
d2e4a39e 1833fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1834{
1835 type = desc_base_type (type);
1836
1837 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1838 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1839 else
14f9c5c9
AS
1840 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1841}
1842
4c4b4cd2 1843/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1844 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
d2e4a39e
AS
1847static struct value *
1848desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1849{
d2e4a39e 1850 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1851 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1852}
1853
1854/* If BOUNDS is an array-bounds structure type, return the bit position
1855 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1856 bound, if WHICH is 1. The first bound is I=1. */
1857
14f9c5c9 1858static int
d2e4a39e 1859desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1860{
d2e4a39e 1861 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1862}
1863
1864/* If BOUNDS is an array-bounds structure type, return the bit field size
1865 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1866 bound, if WHICH is 1. The first bound is I=1. */
1867
76a01679 1868static int
d2e4a39e 1869desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1870{
1871 type = desc_base_type (type);
1872
d2e4a39e
AS
1873 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1874 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1875 else
1876 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1877}
1878
1879/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1880 Ith bound (numbering from 1). Otherwise, NULL. */
1881
d2e4a39e
AS
1882static struct type *
1883desc_index_type (struct type *type, int i)
14f9c5c9
AS
1884{
1885 type = desc_base_type (type);
1886
1887 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1888 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1889 else
14f9c5c9
AS
1890 return NULL;
1891}
1892
4c4b4cd2
PH
1893/* The number of index positions in the array-bounds type TYPE.
1894 Return 0 if TYPE is NULL. */
1895
14f9c5c9 1896static int
d2e4a39e 1897desc_arity (struct type *type)
14f9c5c9
AS
1898{
1899 type = desc_base_type (type);
1900
1901 if (type != NULL)
1902 return TYPE_NFIELDS (type) / 2;
1903 return 0;
1904}
1905
4c4b4cd2
PH
1906/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1907 an array descriptor type (representing an unconstrained array
1908 type). */
1909
76a01679
JB
1910static int
1911ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1912{
1913 if (type == NULL)
1914 return 0;
61ee279c 1915 type = ada_check_typedef (type);
4c4b4cd2 1916 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1917 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1918}
1919
52ce6436 1920/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1921 * to one. */
52ce6436 1922
2c0b251b 1923static int
52ce6436
PH
1924ada_is_array_type (struct type *type)
1925{
1926 while (type != NULL
1927 && (TYPE_CODE (type) == TYPE_CODE_PTR
1928 || TYPE_CODE (type) == TYPE_CODE_REF))
1929 type = TYPE_TARGET_TYPE (type);
1930 return ada_is_direct_array_type (type);
1931}
1932
4c4b4cd2 1933/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1934
14f9c5c9 1935int
4c4b4cd2 1936ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1937{
1938 if (type == NULL)
1939 return 0;
61ee279c 1940 type = ada_check_typedef (type);
14f9c5c9 1941 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1942 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1943 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1944 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1945}
1946
4c4b4cd2
PH
1947/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1948
14f9c5c9 1949int
4c4b4cd2 1950ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1951{
556bdfd4 1952 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1953
1954 if (type == NULL)
1955 return 0;
61ee279c 1956 type = ada_check_typedef (type);
556bdfd4
UW
1957 return (data_type != NULL
1958 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1959 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1960}
1961
1962/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1963 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1964 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1965 is still needed. */
1966
14f9c5c9 1967int
ebf56fd3 1968ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1969{
d2e4a39e 1970 return
14f9c5c9
AS
1971 type != NULL
1972 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1973 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1974 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1975 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1976}
1977
1978
4c4b4cd2 1979/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1980 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1981 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1982 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1983 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1984 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1985 a descriptor. */
d2e4a39e
AS
1986struct type *
1987ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1988{
ad82864c
JB
1989 if (ada_is_constrained_packed_array_type (value_type (arr)))
1990 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1991
df407dfe
AC
1992 if (!ada_is_array_descriptor_type (value_type (arr)))
1993 return value_type (arr);
d2e4a39e
AS
1994
1995 if (!bounds)
ad82864c
JB
1996 {
1997 struct type *array_type =
1998 ada_check_typedef (desc_data_target_type (value_type (arr)));
1999
2000 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2001 TYPE_FIELD_BITSIZE (array_type, 0) =
2002 decode_packed_array_bitsize (value_type (arr));
2003
2004 return array_type;
2005 }
14f9c5c9
AS
2006 else
2007 {
d2e4a39e 2008 struct type *elt_type;
14f9c5c9 2009 int arity;
d2e4a39e 2010 struct value *descriptor;
14f9c5c9 2011
df407dfe
AC
2012 elt_type = ada_array_element_type (value_type (arr), -1);
2013 arity = ada_array_arity (value_type (arr));
14f9c5c9 2014
d2e4a39e 2015 if (elt_type == NULL || arity == 0)
df407dfe 2016 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2017
2018 descriptor = desc_bounds (arr);
d2e4a39e 2019 if (value_as_long (descriptor) == 0)
4c4b4cd2 2020 return NULL;
d2e4a39e 2021 while (arity > 0)
4c4b4cd2 2022 {
e9bb382b
UW
2023 struct type *range_type = alloc_type_copy (value_type (arr));
2024 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2025 struct value *low = desc_one_bound (descriptor, arity, 0);
2026 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2027
5b4ee69b 2028 arity -= 1;
0c9c3474
SA
2029 create_static_range_type (range_type, value_type (low),
2030 longest_to_int (value_as_long (low)),
2031 longest_to_int (value_as_long (high)));
4c4b4cd2 2032 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2033
2034 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2035 {
2036 /* We need to store the element packed bitsize, as well as
2037 recompute the array size, because it was previously
2038 computed based on the unpacked element size. */
2039 LONGEST lo = value_as_long (low);
2040 LONGEST hi = value_as_long (high);
2041
2042 TYPE_FIELD_BITSIZE (elt_type, 0) =
2043 decode_packed_array_bitsize (value_type (arr));
2044 /* If the array has no element, then the size is already
2045 zero, and does not need to be recomputed. */
2046 if (lo < hi)
2047 {
2048 int array_bitsize =
2049 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2050
2051 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2052 }
2053 }
4c4b4cd2 2054 }
14f9c5c9
AS
2055
2056 return lookup_pointer_type (elt_type);
2057 }
2058}
2059
2060/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2061 Otherwise, returns either a standard GDB array with bounds set
2062 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2063 GDB array. Returns NULL if ARR is a null fat pointer. */
2064
d2e4a39e
AS
2065struct value *
2066ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2067{
df407dfe 2068 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2069 {
d2e4a39e 2070 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2071
14f9c5c9 2072 if (arrType == NULL)
4c4b4cd2 2073 return NULL;
14f9c5c9
AS
2074 return value_cast (arrType, value_copy (desc_data (arr)));
2075 }
ad82864c
JB
2076 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2077 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2078 else
2079 return arr;
2080}
2081
2082/* If ARR does not represent an array, returns ARR unchanged.
2083 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2084 be ARR itself if it already is in the proper form). */
2085
720d1a40 2086struct value *
d2e4a39e 2087ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2088{
df407dfe 2089 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2090 {
d2e4a39e 2091 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2092
14f9c5c9 2093 if (arrVal == NULL)
323e0a4a 2094 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2095 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2096 return value_ind (arrVal);
2097 }
ad82864c
JB
2098 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2099 return decode_constrained_packed_array (arr);
d2e4a39e 2100 else
14f9c5c9
AS
2101 return arr;
2102}
2103
2104/* If TYPE represents a GNAT array type, return it translated to an
2105 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2106 packing). For other types, is the identity. */
2107
d2e4a39e
AS
2108struct type *
2109ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2110{
ad82864c
JB
2111 if (ada_is_constrained_packed_array_type (type))
2112 return decode_constrained_packed_array_type (type);
17280b9f
UW
2113
2114 if (ada_is_array_descriptor_type (type))
556bdfd4 2115 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2116
2117 return type;
14f9c5c9
AS
2118}
2119
4c4b4cd2
PH
2120/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2121
ad82864c
JB
2122static int
2123ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2124{
2125 if (type == NULL)
2126 return 0;
4c4b4cd2 2127 type = desc_base_type (type);
61ee279c 2128 type = ada_check_typedef (type);
d2e4a39e 2129 return
14f9c5c9
AS
2130 ada_type_name (type) != NULL
2131 && strstr (ada_type_name (type), "___XP") != NULL;
2132}
2133
ad82864c
JB
2134/* Non-zero iff TYPE represents a standard GNAT constrained
2135 packed-array type. */
2136
2137int
2138ada_is_constrained_packed_array_type (struct type *type)
2139{
2140 return ada_is_packed_array_type (type)
2141 && !ada_is_array_descriptor_type (type);
2142}
2143
2144/* Non-zero iff TYPE represents an array descriptor for a
2145 unconstrained packed-array type. */
2146
2147static int
2148ada_is_unconstrained_packed_array_type (struct type *type)
2149{
2150 return ada_is_packed_array_type (type)
2151 && ada_is_array_descriptor_type (type);
2152}
2153
2154/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2155 return the size of its elements in bits. */
2156
2157static long
2158decode_packed_array_bitsize (struct type *type)
2159{
0d5cff50
DE
2160 const char *raw_name;
2161 const char *tail;
ad82864c
JB
2162 long bits;
2163
720d1a40
JB
2164 /* Access to arrays implemented as fat pointers are encoded as a typedef
2165 of the fat pointer type. We need the name of the fat pointer type
2166 to do the decoding, so strip the typedef layer. */
2167 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2168 type = ada_typedef_target_type (type);
2169
2170 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2171 if (!raw_name)
2172 raw_name = ada_type_name (desc_base_type (type));
2173
2174 if (!raw_name)
2175 return 0;
2176
2177 tail = strstr (raw_name, "___XP");
720d1a40 2178 gdb_assert (tail != NULL);
ad82864c
JB
2179
2180 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2181 {
2182 lim_warning
2183 (_("could not understand bit size information on packed array"));
2184 return 0;
2185 }
2186
2187 return bits;
2188}
2189
14f9c5c9
AS
2190/* Given that TYPE is a standard GDB array type with all bounds filled
2191 in, and that the element size of its ultimate scalar constituents
2192 (that is, either its elements, or, if it is an array of arrays, its
2193 elements' elements, etc.) is *ELT_BITS, return an identical type,
2194 but with the bit sizes of its elements (and those of any
2195 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2196 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2197 in bits.
2198
2199 Note that, for arrays whose index type has an XA encoding where
2200 a bound references a record discriminant, getting that discriminant,
2201 and therefore the actual value of that bound, is not possible
2202 because none of the given parameters gives us access to the record.
2203 This function assumes that it is OK in the context where it is being
2204 used to return an array whose bounds are still dynamic and where
2205 the length is arbitrary. */
4c4b4cd2 2206
d2e4a39e 2207static struct type *
ad82864c 2208constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2209{
d2e4a39e
AS
2210 struct type *new_elt_type;
2211 struct type *new_type;
99b1c762
JB
2212 struct type *index_type_desc;
2213 struct type *index_type;
14f9c5c9
AS
2214 LONGEST low_bound, high_bound;
2215
61ee279c 2216 type = ada_check_typedef (type);
14f9c5c9
AS
2217 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2218 return type;
2219
99b1c762
JB
2220 index_type_desc = ada_find_parallel_type (type, "___XA");
2221 if (index_type_desc)
2222 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2223 NULL);
2224 else
2225 index_type = TYPE_INDEX_TYPE (type);
2226
e9bb382b 2227 new_type = alloc_type_copy (type);
ad82864c
JB
2228 new_elt_type =
2229 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2230 elt_bits);
99b1c762 2231 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2232 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2233 TYPE_NAME (new_type) = ada_type_name (type);
2234
4a46959e
JB
2235 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2236 && is_dynamic_type (check_typedef (index_type)))
2237 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2238 low_bound = high_bound = 0;
2239 if (high_bound < low_bound)
2240 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2241 else
14f9c5c9
AS
2242 {
2243 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2244 TYPE_LENGTH (new_type) =
4c4b4cd2 2245 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2246 }
2247
876cecd0 2248 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2249 return new_type;
2250}
2251
ad82864c
JB
2252/* The array type encoded by TYPE, where
2253 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2254
d2e4a39e 2255static struct type *
ad82864c 2256decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2257{
0d5cff50 2258 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2259 char *name;
0d5cff50 2260 const char *tail;
d2e4a39e 2261 struct type *shadow_type;
14f9c5c9 2262 long bits;
14f9c5c9 2263
727e3d2e
JB
2264 if (!raw_name)
2265 raw_name = ada_type_name (desc_base_type (type));
2266
2267 if (!raw_name)
2268 return NULL;
2269
2270 name = (char *) alloca (strlen (raw_name) + 1);
2271 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2272 type = desc_base_type (type);
2273
14f9c5c9
AS
2274 memcpy (name, raw_name, tail - raw_name);
2275 name[tail - raw_name] = '\000';
2276
b4ba55a1
JB
2277 shadow_type = ada_find_parallel_type_with_name (type, name);
2278
2279 if (shadow_type == NULL)
14f9c5c9 2280 {
323e0a4a 2281 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2282 return NULL;
2283 }
f168693b 2284 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2285
2286 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2287 {
0963b4bd
MS
2288 lim_warning (_("could not understand bounds "
2289 "information on packed array"));
14f9c5c9
AS
2290 return NULL;
2291 }
d2e4a39e 2292
ad82864c
JB
2293 bits = decode_packed_array_bitsize (type);
2294 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2295}
2296
ad82864c
JB
2297/* Given that ARR is a struct value *indicating a GNAT constrained packed
2298 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2299 standard GDB array type except that the BITSIZEs of the array
2300 target types are set to the number of bits in each element, and the
4c4b4cd2 2301 type length is set appropriately. */
14f9c5c9 2302
d2e4a39e 2303static struct value *
ad82864c 2304decode_constrained_packed_array (struct value *arr)
14f9c5c9 2305{
4c4b4cd2 2306 struct type *type;
14f9c5c9 2307
11aa919a
PMR
2308 /* If our value is a pointer, then dereference it. Likewise if
2309 the value is a reference. Make sure that this operation does not
2310 cause the target type to be fixed, as this would indirectly cause
2311 this array to be decoded. The rest of the routine assumes that
2312 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2313 and "value_ind" routines to perform the dereferencing, as opposed
2314 to using "ada_coerce_ref" or "ada_value_ind". */
2315 arr = coerce_ref (arr);
828292f2 2316 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2317 arr = value_ind (arr);
4c4b4cd2 2318
ad82864c 2319 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2320 if (type == NULL)
2321 {
323e0a4a 2322 error (_("can't unpack array"));
14f9c5c9
AS
2323 return NULL;
2324 }
61ee279c 2325
50810684 2326 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2327 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2328 {
2329 /* This is a (right-justified) modular type representing a packed
2330 array with no wrapper. In order to interpret the value through
2331 the (left-justified) packed array type we just built, we must
2332 first left-justify it. */
2333 int bit_size, bit_pos;
2334 ULONGEST mod;
2335
df407dfe 2336 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2337 bit_size = 0;
2338 while (mod > 0)
2339 {
2340 bit_size += 1;
2341 mod >>= 1;
2342 }
df407dfe 2343 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2344 arr = ada_value_primitive_packed_val (arr, NULL,
2345 bit_pos / HOST_CHAR_BIT,
2346 bit_pos % HOST_CHAR_BIT,
2347 bit_size,
2348 type);
2349 }
2350
4c4b4cd2 2351 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2352}
2353
2354
2355/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2356 given in IND. ARR must be a simple array. */
14f9c5c9 2357
d2e4a39e
AS
2358static struct value *
2359value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2360{
2361 int i;
2362 int bits, elt_off, bit_off;
2363 long elt_total_bit_offset;
d2e4a39e
AS
2364 struct type *elt_type;
2365 struct value *v;
14f9c5c9
AS
2366
2367 bits = 0;
2368 elt_total_bit_offset = 0;
df407dfe 2369 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2370 for (i = 0; i < arity; i += 1)
14f9c5c9 2371 {
d2e4a39e 2372 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2373 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2374 error
0963b4bd
MS
2375 (_("attempt to do packed indexing of "
2376 "something other than a packed array"));
14f9c5c9 2377 else
4c4b4cd2
PH
2378 {
2379 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2380 LONGEST lowerbound, upperbound;
2381 LONGEST idx;
2382
2383 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2384 {
323e0a4a 2385 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2386 lowerbound = upperbound = 0;
2387 }
2388
3cb382c9 2389 idx = pos_atr (ind[i]);
4c4b4cd2 2390 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2391 lim_warning (_("packed array index %ld out of bounds"),
2392 (long) idx);
4c4b4cd2
PH
2393 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2394 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2395 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2396 }
14f9c5c9
AS
2397 }
2398 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2399 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2400
2401 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2402 bits, elt_type);
14f9c5c9
AS
2403 return v;
2404}
2405
4c4b4cd2 2406/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2407
2408static int
d2e4a39e 2409has_negatives (struct type *type)
14f9c5c9 2410{
d2e4a39e
AS
2411 switch (TYPE_CODE (type))
2412 {
2413 default:
2414 return 0;
2415 case TYPE_CODE_INT:
2416 return !TYPE_UNSIGNED (type);
2417 case TYPE_CODE_RANGE:
2418 return TYPE_LOW_BOUND (type) < 0;
2419 }
14f9c5c9 2420}
d2e4a39e 2421
f93fca70 2422/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2423 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2424 the unpacked buffer.
14f9c5c9 2425
5b639dea
JB
2426 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2427 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2428
f93fca70
JB
2429 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2430 zero otherwise.
14f9c5c9 2431
f93fca70 2432 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2433
f93fca70
JB
2434 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2435
2436static void
2437ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2438 gdb_byte *unpacked, int unpacked_len,
2439 int is_big_endian, int is_signed_type,
2440 int is_scalar)
2441{
a1c95e6b
JB
2442 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2443 int src_idx; /* Index into the source area */
2444 int src_bytes_left; /* Number of source bytes left to process. */
2445 int srcBitsLeft; /* Number of source bits left to move */
2446 int unusedLS; /* Number of bits in next significant
2447 byte of source that are unused */
2448
a1c95e6b
JB
2449 int unpacked_idx; /* Index into the unpacked buffer */
2450 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2451
4c4b4cd2 2452 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2453 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2454 unsigned char sign;
a1c95e6b 2455
4c4b4cd2
PH
2456 /* Transmit bytes from least to most significant; delta is the direction
2457 the indices move. */
f93fca70 2458 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2459
5b639dea
JB
2460 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2461 bits from SRC. .*/
2462 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2463 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2464 bit_size, unpacked_len);
2465
14f9c5c9 2466 srcBitsLeft = bit_size;
086ca51f 2467 src_bytes_left = src_len;
f93fca70 2468 unpacked_bytes_left = unpacked_len;
14f9c5c9 2469 sign = 0;
f93fca70
JB
2470
2471 if (is_big_endian)
14f9c5c9 2472 {
086ca51f 2473 src_idx = src_len - 1;
f93fca70
JB
2474 if (is_signed_type
2475 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2476 sign = ~0;
d2e4a39e
AS
2477
2478 unusedLS =
4c4b4cd2
PH
2479 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2480 % HOST_CHAR_BIT;
14f9c5c9 2481
f93fca70
JB
2482 if (is_scalar)
2483 {
2484 accumSize = 0;
2485 unpacked_idx = unpacked_len - 1;
2486 }
2487 else
2488 {
4c4b4cd2
PH
2489 /* Non-scalar values must be aligned at a byte boundary... */
2490 accumSize =
2491 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2492 /* ... And are placed at the beginning (most-significant) bytes
2493 of the target. */
086ca51f
JB
2494 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2495 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2496 }
14f9c5c9 2497 }
d2e4a39e 2498 else
14f9c5c9
AS
2499 {
2500 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2501
086ca51f 2502 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2503 unusedLS = bit_offset;
2504 accumSize = 0;
2505
f93fca70 2506 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2507 sign = ~0;
14f9c5c9 2508 }
d2e4a39e 2509
14f9c5c9 2510 accum = 0;
086ca51f 2511 while (src_bytes_left > 0)
14f9c5c9
AS
2512 {
2513 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2514 part of the value. */
d2e4a39e 2515 unsigned int unusedMSMask =
4c4b4cd2
PH
2516 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2517 1;
2518 /* Sign-extend bits for this byte. */
14f9c5c9 2519 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2520
d2e4a39e 2521 accum |=
086ca51f 2522 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2523 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2524 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2525 {
db297a65 2526 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2527 accumSize -= HOST_CHAR_BIT;
2528 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2529 unpacked_bytes_left -= 1;
2530 unpacked_idx += delta;
4c4b4cd2 2531 }
14f9c5c9
AS
2532 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2533 unusedLS = 0;
086ca51f
JB
2534 src_bytes_left -= 1;
2535 src_idx += delta;
14f9c5c9 2536 }
086ca51f 2537 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2538 {
2539 accum |= sign << accumSize;
db297a65 2540 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2541 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2542 if (accumSize < 0)
2543 accumSize = 0;
14f9c5c9 2544 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2545 unpacked_bytes_left -= 1;
2546 unpacked_idx += delta;
14f9c5c9 2547 }
f93fca70
JB
2548}
2549
2550/* Create a new value of type TYPE from the contents of OBJ starting
2551 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2552 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2553 assigning through the result will set the field fetched from.
2554 VALADDR is ignored unless OBJ is NULL, in which case,
2555 VALADDR+OFFSET must address the start of storage containing the
2556 packed value. The value returned in this case is never an lval.
2557 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2558
2559struct value *
2560ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2561 long offset, int bit_offset, int bit_size,
2562 struct type *type)
2563{
2564 struct value *v;
bfb1c796 2565 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2566 gdb_byte *unpacked;
220475ed 2567 const int is_scalar = is_scalar_type (type);
d0a9e810 2568 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
d5722aa2 2569 gdb::byte_vector staging;
f93fca70
JB
2570
2571 type = ada_check_typedef (type);
2572
d0a9e810 2573 if (obj == NULL)
bfb1c796 2574 src = valaddr + offset;
d0a9e810 2575 else
bfb1c796 2576 src = value_contents (obj) + offset;
d0a9e810
JB
2577
2578 if (is_dynamic_type (type))
2579 {
2580 /* The length of TYPE might by dynamic, so we need to resolve
2581 TYPE in order to know its actual size, which we then use
2582 to create the contents buffer of the value we return.
2583 The difficulty is that the data containing our object is
2584 packed, and therefore maybe not at a byte boundary. So, what
2585 we do, is unpack the data into a byte-aligned buffer, and then
2586 use that buffer as our object's value for resolving the type. */
d5722aa2
PA
2587 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2588 staging.resize (staging_len);
d0a9e810
JB
2589
2590 ada_unpack_from_contents (src, bit_offset, bit_size,
d5722aa2 2591 staging.data (), staging.size (),
d0a9e810
JB
2592 is_big_endian, has_negatives (type),
2593 is_scalar);
d5722aa2 2594 type = resolve_dynamic_type (type, staging.data (), 0);
0cafa88c
JB
2595 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2596 {
2597 /* This happens when the length of the object is dynamic,
2598 and is actually smaller than the space reserved for it.
2599 For instance, in an array of variant records, the bit_size
2600 we're given is the array stride, which is constant and
2601 normally equal to the maximum size of its element.
2602 But, in reality, each element only actually spans a portion
2603 of that stride. */
2604 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2605 }
d0a9e810
JB
2606 }
2607
f93fca70
JB
2608 if (obj == NULL)
2609 {
2610 v = allocate_value (type);
bfb1c796 2611 src = valaddr + offset;
f93fca70
JB
2612 }
2613 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2614 {
0cafa88c 2615 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2616 gdb_byte *buf;
0cafa88c 2617
f93fca70 2618 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2619 buf = (gdb_byte *) alloca (src_len);
2620 read_memory (value_address (v), buf, src_len);
2621 src = buf;
f93fca70
JB
2622 }
2623 else
2624 {
2625 v = allocate_value (type);
bfb1c796 2626 src = value_contents (obj) + offset;
f93fca70
JB
2627 }
2628
2629 if (obj != NULL)
2630 {
2631 long new_offset = offset;
2632
2633 set_value_component_location (v, obj);
2634 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2635 set_value_bitsize (v, bit_size);
2636 if (value_bitpos (v) >= HOST_CHAR_BIT)
2637 {
2638 ++new_offset;
2639 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2640 }
2641 set_value_offset (v, new_offset);
2642
2643 /* Also set the parent value. This is needed when trying to
2644 assign a new value (in inferior memory). */
2645 set_value_parent (v, obj);
2646 }
2647 else
2648 set_value_bitsize (v, bit_size);
bfb1c796 2649 unpacked = value_contents_writeable (v);
f93fca70
JB
2650
2651 if (bit_size == 0)
2652 {
2653 memset (unpacked, 0, TYPE_LENGTH (type));
2654 return v;
2655 }
2656
d5722aa2 2657 if (staging.size () == TYPE_LENGTH (type))
f93fca70 2658 {
d0a9e810
JB
2659 /* Small short-cut: If we've unpacked the data into a buffer
2660 of the same size as TYPE's length, then we can reuse that,
2661 instead of doing the unpacking again. */
d5722aa2 2662 memcpy (unpacked, staging.data (), staging.size ());
f93fca70 2663 }
d0a9e810
JB
2664 else
2665 ada_unpack_from_contents (src, bit_offset, bit_size,
2666 unpacked, TYPE_LENGTH (type),
2667 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2668
14f9c5c9
AS
2669 return v;
2670}
d2e4a39e 2671
14f9c5c9
AS
2672/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2673 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2674 not overlap. */
14f9c5c9 2675static void
fc1a4b47 2676move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2677 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2678{
2679 unsigned int accum, mask;
2680 int accum_bits, chunk_size;
2681
2682 target += targ_offset / HOST_CHAR_BIT;
2683 targ_offset %= HOST_CHAR_BIT;
2684 source += src_offset / HOST_CHAR_BIT;
2685 src_offset %= HOST_CHAR_BIT;
50810684 2686 if (bits_big_endian_p)
14f9c5c9
AS
2687 {
2688 accum = (unsigned char) *source;
2689 source += 1;
2690 accum_bits = HOST_CHAR_BIT - src_offset;
2691
d2e4a39e 2692 while (n > 0)
4c4b4cd2
PH
2693 {
2694 int unused_right;
5b4ee69b 2695
4c4b4cd2
PH
2696 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2697 accum_bits += HOST_CHAR_BIT;
2698 source += 1;
2699 chunk_size = HOST_CHAR_BIT - targ_offset;
2700 if (chunk_size > n)
2701 chunk_size = n;
2702 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2703 mask = ((1 << chunk_size) - 1) << unused_right;
2704 *target =
2705 (*target & ~mask)
2706 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2707 n -= chunk_size;
2708 accum_bits -= chunk_size;
2709 target += 1;
2710 targ_offset = 0;
2711 }
14f9c5c9
AS
2712 }
2713 else
2714 {
2715 accum = (unsigned char) *source >> src_offset;
2716 source += 1;
2717 accum_bits = HOST_CHAR_BIT - src_offset;
2718
d2e4a39e 2719 while (n > 0)
4c4b4cd2
PH
2720 {
2721 accum = accum + ((unsigned char) *source << accum_bits);
2722 accum_bits += HOST_CHAR_BIT;
2723 source += 1;
2724 chunk_size = HOST_CHAR_BIT - targ_offset;
2725 if (chunk_size > n)
2726 chunk_size = n;
2727 mask = ((1 << chunk_size) - 1) << targ_offset;
2728 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2729 n -= chunk_size;
2730 accum_bits -= chunk_size;
2731 accum >>= chunk_size;
2732 target += 1;
2733 targ_offset = 0;
2734 }
14f9c5c9
AS
2735 }
2736}
2737
14f9c5c9
AS
2738/* Store the contents of FROMVAL into the location of TOVAL.
2739 Return a new value with the location of TOVAL and contents of
2740 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2741 floating-point or non-scalar types. */
14f9c5c9 2742
d2e4a39e
AS
2743static struct value *
2744ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2745{
df407dfe
AC
2746 struct type *type = value_type (toval);
2747 int bits = value_bitsize (toval);
14f9c5c9 2748
52ce6436
PH
2749 toval = ada_coerce_ref (toval);
2750 fromval = ada_coerce_ref (fromval);
2751
2752 if (ada_is_direct_array_type (value_type (toval)))
2753 toval = ada_coerce_to_simple_array (toval);
2754 if (ada_is_direct_array_type (value_type (fromval)))
2755 fromval = ada_coerce_to_simple_array (fromval);
2756
88e3b34b 2757 if (!deprecated_value_modifiable (toval))
323e0a4a 2758 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2759
d2e4a39e 2760 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2761 && bits > 0
d2e4a39e 2762 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2763 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2764 {
df407dfe
AC
2765 int len = (value_bitpos (toval)
2766 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2767 int from_size;
224c3ddb 2768 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2769 struct value *val;
42ae5230 2770 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2771
2772 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2773 fromval = value_cast (type, fromval);
14f9c5c9 2774
52ce6436 2775 read_memory (to_addr, buffer, len);
aced2898
PH
2776 from_size = value_bitsize (fromval);
2777 if (from_size == 0)
2778 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2779 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2780 move_bits (buffer, value_bitpos (toval),
50810684 2781 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2782 else
50810684
UW
2783 move_bits (buffer, value_bitpos (toval),
2784 value_contents (fromval), 0, bits, 0);
972daa01 2785 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2786
14f9c5c9 2787 val = value_copy (toval);
0fd88904 2788 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2789 TYPE_LENGTH (type));
04624583 2790 deprecated_set_value_type (val, type);
d2e4a39e 2791
14f9c5c9
AS
2792 return val;
2793 }
2794
2795 return value_assign (toval, fromval);
2796}
2797
2798
7c512744
JB
2799/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2800 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2801 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2802 COMPONENT, and not the inferior's memory. The current contents
2803 of COMPONENT are ignored.
2804
2805 Although not part of the initial design, this function also works
2806 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2807 had a null address, and COMPONENT had an address which is equal to
2808 its offset inside CONTAINER. */
2809
52ce6436
PH
2810static void
2811value_assign_to_component (struct value *container, struct value *component,
2812 struct value *val)
2813{
2814 LONGEST offset_in_container =
42ae5230 2815 (LONGEST) (value_address (component) - value_address (container));
7c512744 2816 int bit_offset_in_container =
52ce6436
PH
2817 value_bitpos (component) - value_bitpos (container);
2818 int bits;
7c512744 2819
52ce6436
PH
2820 val = value_cast (value_type (component), val);
2821
2822 if (value_bitsize (component) == 0)
2823 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2824 else
2825 bits = value_bitsize (component);
2826
50810684 2827 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
7c512744 2828 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436
PH
2829 value_bitpos (container) + bit_offset_in_container,
2830 value_contents (val),
2831 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2832 bits, 1);
52ce6436 2833 else
7c512744 2834 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2835 value_bitpos (container) + bit_offset_in_container,
50810684 2836 value_contents (val), 0, bits, 0);
7c512744
JB
2837}
2838
4c4b4cd2
PH
2839/* The value of the element of array ARR at the ARITY indices given in IND.
2840 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2841 thereto. */
2842
d2e4a39e
AS
2843struct value *
2844ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2845{
2846 int k;
d2e4a39e
AS
2847 struct value *elt;
2848 struct type *elt_type;
14f9c5c9
AS
2849
2850 elt = ada_coerce_to_simple_array (arr);
2851
df407dfe 2852 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2853 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2854 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2855 return value_subscript_packed (elt, arity, ind);
2856
2857 for (k = 0; k < arity; k += 1)
2858 {
2859 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2860 error (_("too many subscripts (%d expected)"), k);
2497b498 2861 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2862 }
2863 return elt;
2864}
2865
deede10c
JB
2866/* Assuming ARR is a pointer to a GDB array, the value of the element
2867 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2868 Does not read the entire array into memory.
2869
2870 Note: Unlike what one would expect, this function is used instead of
2871 ada_value_subscript for basically all non-packed array types. The reason
2872 for this is that a side effect of doing our own pointer arithmetics instead
2873 of relying on value_subscript is that there is no implicit typedef peeling.
2874 This is important for arrays of array accesses, where it allows us to
2875 preserve the fact that the array's element is an array access, where the
2876 access part os encoded in a typedef layer. */
14f9c5c9 2877
2c0b251b 2878static struct value *
deede10c 2879ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2880{
2881 int k;
919e6dbe 2882 struct value *array_ind = ada_value_ind (arr);
deede10c 2883 struct type *type
919e6dbe
PMR
2884 = check_typedef (value_enclosing_type (array_ind));
2885
2886 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2887 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2888 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2889
2890 for (k = 0; k < arity; k += 1)
2891 {
2892 LONGEST lwb, upb;
aa715135 2893 struct value *lwb_value;
14f9c5c9
AS
2894
2895 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2896 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2897 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2898 value_copy (arr));
14f9c5c9 2899 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2900 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2901 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2902 type = TYPE_TARGET_TYPE (type);
2903 }
2904
2905 return value_ind (arr);
2906}
2907
0b5d8877 2908/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2909 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2910 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2911 this array is LOW, as per Ada rules. */
0b5d8877 2912static struct value *
f5938064
JG
2913ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2914 int low, int high)
0b5d8877 2915{
b0dd7688 2916 struct type *type0 = ada_check_typedef (type);
aa715135 2917 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2918 struct type *index_type
aa715135 2919 = create_static_range_type (NULL, base_index_type, low, high);
6c038f32 2920 struct type *slice_type =
b0dd7688 2921 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
aa715135
JG
2922 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2923 LONGEST base_low_pos, low_pos;
2924 CORE_ADDR base;
2925
2926 if (!discrete_position (base_index_type, low, &low_pos)
2927 || !discrete_position (base_index_type, base_low, &base_low_pos))
2928 {
2929 warning (_("unable to get positions in slice, use bounds instead"));
2930 low_pos = low;
2931 base_low_pos = base_low;
2932 }
5b4ee69b 2933
aa715135
JG
2934 base = value_as_address (array_ptr)
2935 + ((low_pos - base_low_pos)
2936 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2937 return value_at_lazy (slice_type, base);
0b5d8877
PH
2938}
2939
2940
2941static struct value *
2942ada_value_slice (struct value *array, int low, int high)
2943{
b0dd7688 2944 struct type *type = ada_check_typedef (value_type (array));
aa715135 2945 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2946 struct type *index_type
2947 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2948 struct type *slice_type =
0b5d8877 2949 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
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);
aa715135
JG
3185 index_type = TYPE_INDEX_TYPE (arr_type);
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
PH
3244static void
3245resolve (struct expression **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 *
4c4b4cd2 3266resolve_subexp (struct expression **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;
3279 exp = *expp;
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
PH
3385 case OP_LONG:
3386 case OP_DOUBLE:
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;
3429 exp = *expp;
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 {
d12307c1 3440 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
3491 && !is_nonfunction (candidates, n_candidates))
3492 {
06d5cf63
JB
3493 i = ada_resolve_function
3494 (candidates, n_candidates, NULL, 0,
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
JB
3504 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3505 user_select_syms (candidates, n_candidates, 1);
3506 i = 0;
3507 }
3508
3509 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3510 exp->elts[pc + 2].symbol = candidates[i].symbol;
1265e4aa
JB
3511 if (innermost_block == NULL
3512 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3513 innermost_block = candidates[i].block;
3514 }
3515
3516 if (deprocedure_p
3517 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3518 == TYPE_CODE_FUNC))
3519 {
3520 replace_operator_with_call (expp, pc, 0, 0,
3521 exp->elts[pc + 2].symbol,
3522 exp->elts[pc + 1].block);
3523 exp = *expp;
3524 }
14f9c5c9
AS
3525 break;
3526
3527 case OP_FUNCALL:
3528 {
4c4b4cd2 3529 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3530 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3531 {
d12307c1 3532 struct block_symbol *candidates;
4c4b4cd2
PH
3533 int n_candidates;
3534
3535 n_candidates =
76a01679
JB
3536 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3537 (exp->elts[pc + 5].symbol),
3538 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3539 &candidates);
4c4b4cd2
PH
3540 if (n_candidates == 1)
3541 i = 0;
3542 else
3543 {
06d5cf63
JB
3544 i = ada_resolve_function
3545 (candidates, n_candidates,
3546 argvec, nargs,
3547 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3548 context_type);
4c4b4cd2 3549 if (i < 0)
323e0a4a 3550 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3551 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3552 }
3553
3554 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3555 exp->elts[pc + 5].symbol = candidates[i].symbol;
1265e4aa
JB
3556 if (innermost_block == NULL
3557 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3558 innermost_block = candidates[i].block;
3559 }
14f9c5c9
AS
3560 }
3561 break;
3562 case BINOP_ADD:
3563 case BINOP_SUB:
3564 case BINOP_MUL:
3565 case BINOP_DIV:
3566 case BINOP_REM:
3567 case BINOP_MOD:
3568 case BINOP_CONCAT:
3569 case BINOP_BITWISE_AND:
3570 case BINOP_BITWISE_IOR:
3571 case BINOP_BITWISE_XOR:
3572 case BINOP_EQUAL:
3573 case BINOP_NOTEQUAL:
3574 case BINOP_LESS:
3575 case BINOP_GTR:
3576 case BINOP_LEQ:
3577 case BINOP_GEQ:
3578 case BINOP_EXP:
3579 case UNOP_NEG:
3580 case UNOP_PLUS:
3581 case UNOP_LOGICAL_NOT:
3582 case UNOP_ABS:
3583 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3584 {
d12307c1 3585 struct block_symbol *candidates;
4c4b4cd2
PH
3586 int n_candidates;
3587
3588 n_candidates =
3589 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3590 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3591 &candidates);
4c4b4cd2 3592 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3593 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3594 if (i < 0)
3595 break;
3596
d12307c1
PMR
3597 replace_operator_with_call (expp, pc, nargs, 1,
3598 candidates[i].symbol,
3599 candidates[i].block);
4c4b4cd2
PH
3600 exp = *expp;
3601 }
14f9c5c9 3602 break;
4c4b4cd2
PH
3603
3604 case OP_TYPE:
b3dbf008 3605 case OP_REGISTER:
4c4b4cd2 3606 return NULL;
14f9c5c9
AS
3607 }
3608
3609 *pos = pc;
3610 return evaluate_subexp_type (exp, pos);
3611}
3612
3613/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3614 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3615 a non-pointer. */
14f9c5c9 3616/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3617 liberal. */
14f9c5c9
AS
3618
3619static int
4dc81987 3620ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3621{
61ee279c
PH
3622 ftype = ada_check_typedef (ftype);
3623 atype = ada_check_typedef (atype);
14f9c5c9
AS
3624
3625 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3626 ftype = TYPE_TARGET_TYPE (ftype);
3627 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3628 atype = TYPE_TARGET_TYPE (atype);
3629
d2e4a39e 3630 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3631 {
3632 default:
5b3d5b7d 3633 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3634 case TYPE_CODE_PTR:
3635 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3636 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3637 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3638 else
1265e4aa
JB
3639 return (may_deref
3640 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3641 case TYPE_CODE_INT:
3642 case TYPE_CODE_ENUM:
3643 case TYPE_CODE_RANGE:
3644 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3645 {
3646 case TYPE_CODE_INT:
3647 case TYPE_CODE_ENUM:
3648 case TYPE_CODE_RANGE:
3649 return 1;
3650 default:
3651 return 0;
3652 }
14f9c5c9
AS
3653
3654 case TYPE_CODE_ARRAY:
d2e4a39e 3655 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3656 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3657
3658 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3659 if (ada_is_array_descriptor_type (ftype))
3660 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3661 || ada_is_array_descriptor_type (atype));
14f9c5c9 3662 else
4c4b4cd2
PH
3663 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3664 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3665
3666 case TYPE_CODE_UNION:
3667 case TYPE_CODE_FLT:
3668 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3669 }
3670}
3671
3672/* Return non-zero if the formals of FUNC "sufficiently match" the
3673 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3674 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3675 argument function. */
14f9c5c9
AS
3676
3677static int
d2e4a39e 3678ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3679{
3680 int i;
d2e4a39e 3681 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3682
1265e4aa
JB
3683 if (SYMBOL_CLASS (func) == LOC_CONST
3684 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3685 return (n_actuals == 0);
3686 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3687 return 0;
3688
3689 if (TYPE_NFIELDS (func_type) != n_actuals)
3690 return 0;
3691
3692 for (i = 0; i < n_actuals; i += 1)
3693 {
4c4b4cd2 3694 if (actuals[i] == NULL)
76a01679
JB
3695 return 0;
3696 else
3697 {
5b4ee69b
MS
3698 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3699 i));
df407dfe 3700 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3701
76a01679
JB
3702 if (!ada_type_match (ftype, atype, 1))
3703 return 0;
3704 }
14f9c5c9
AS
3705 }
3706 return 1;
3707}
3708
3709/* False iff function type FUNC_TYPE definitely does not produce a value
3710 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3711 FUNC_TYPE is not a valid function type with a non-null return type
3712 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3713
3714static int
d2e4a39e 3715return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3716{
d2e4a39e 3717 struct type *return_type;
14f9c5c9
AS
3718
3719 if (func_type == NULL)
3720 return 1;
3721
4c4b4cd2 3722 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3723 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3724 else
18af8284 3725 return_type = get_base_type (func_type);
14f9c5c9
AS
3726 if (return_type == NULL)
3727 return 1;
3728
18af8284 3729 context_type = get_base_type (context_type);
14f9c5c9
AS
3730
3731 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3732 return context_type == NULL || return_type == context_type;
3733 else if (context_type == NULL)
3734 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3735 else
3736 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3737}
3738
3739
4c4b4cd2 3740/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3741 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3742 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3743 that returns that type, then eliminate matches that don't. If
3744 CONTEXT_TYPE is void and there is at least one match that does not
3745 return void, eliminate all matches that do.
3746
14f9c5c9
AS
3747 Asks the user if there is more than one match remaining. Returns -1
3748 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3749 solely for messages. May re-arrange and modify SYMS in
3750 the process; the index returned is for the modified vector. */
14f9c5c9 3751
4c4b4cd2 3752static int
d12307c1 3753ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3754 int nsyms, struct value **args, int nargs,
3755 const char *name, struct type *context_type)
14f9c5c9 3756{
30b15541 3757 int fallback;
14f9c5c9 3758 int k;
4c4b4cd2 3759 int m; /* Number of hits */
14f9c5c9 3760
d2e4a39e 3761 m = 0;
30b15541
UW
3762 /* In the first pass of the loop, we only accept functions matching
3763 context_type. If none are found, we add a second pass of the loop
3764 where every function is accepted. */
3765 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3766 {
3767 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3768 {
d12307c1 3769 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3770
d12307c1 3771 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3772 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3773 {
3774 syms[m] = syms[k];
3775 m += 1;
3776 }
3777 }
14f9c5c9
AS
3778 }
3779
dc5c8746
PMR
3780 /* If we got multiple matches, ask the user which one to use. Don't do this
3781 interactive thing during completion, though, as the purpose of the
3782 completion is providing a list of all possible matches. Prompting the
3783 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3784 if (m == 0)
3785 return -1;
dc5c8746 3786 else if (m > 1 && !parse_completion)
14f9c5c9 3787 {
323e0a4a 3788 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3789 user_select_syms (syms, m, 1);
14f9c5c9
AS
3790 return 0;
3791 }
3792 return 0;
3793}
3794
4c4b4cd2
PH
3795/* Returns true (non-zero) iff decoded name N0 should appear before N1
3796 in a listing of choices during disambiguation (see sort_choices, below).
3797 The idea is that overloadings of a subprogram name from the
3798 same package should sort in their source order. We settle for ordering
3799 such symbols by their trailing number (__N or $N). */
3800
14f9c5c9 3801static int
0d5cff50 3802encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3803{
3804 if (N1 == NULL)
3805 return 0;
3806 else if (N0 == NULL)
3807 return 1;
3808 else
3809 {
3810 int k0, k1;
5b4ee69b 3811
d2e4a39e 3812 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3813 ;
d2e4a39e 3814 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3815 ;
d2e4a39e 3816 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3817 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3818 {
3819 int n0, n1;
5b4ee69b 3820
4c4b4cd2
PH
3821 n0 = k0;
3822 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3823 n0 -= 1;
3824 n1 = k1;
3825 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3826 n1 -= 1;
3827 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3828 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3829 }
14f9c5c9
AS
3830 return (strcmp (N0, N1) < 0);
3831 }
3832}
d2e4a39e 3833
4c4b4cd2
PH
3834/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3835 encoded names. */
3836
d2e4a39e 3837static void
d12307c1 3838sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3839{
4c4b4cd2 3840 int i;
5b4ee69b 3841
d2e4a39e 3842 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3843 {
d12307c1 3844 struct block_symbol sym = syms[i];
14f9c5c9
AS
3845 int j;
3846
d2e4a39e 3847 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3848 {
d12307c1
PMR
3849 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3850 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3851 break;
3852 syms[j + 1] = syms[j];
3853 }
d2e4a39e 3854 syms[j + 1] = sym;
14f9c5c9
AS
3855 }
3856}
3857
d72413e6
PMR
3858/* Whether GDB should display formals and return types for functions in the
3859 overloads selection menu. */
3860static int print_signatures = 1;
3861
3862/* Print the signature for SYM on STREAM according to the FLAGS options. For
3863 all but functions, the signature is just the name of the symbol. For
3864 functions, this is the name of the function, the list of types for formals
3865 and the return type (if any). */
3866
3867static void
3868ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3869 const struct type_print_options *flags)
3870{
3871 struct type *type = SYMBOL_TYPE (sym);
3872
3873 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3874 if (!print_signatures
3875 || type == NULL
3876 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3877 return;
3878
3879 if (TYPE_NFIELDS (type) > 0)
3880 {
3881 int i;
3882
3883 fprintf_filtered (stream, " (");
3884 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3885 {
3886 if (i > 0)
3887 fprintf_filtered (stream, "; ");
3888 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3889 flags);
3890 }
3891 fprintf_filtered (stream, ")");
3892 }
3893 if (TYPE_TARGET_TYPE (type) != NULL
3894 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3895 {
3896 fprintf_filtered (stream, " return ");
3897 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3898 }
3899}
3900
4c4b4cd2
PH
3901/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3902 by asking the user (if necessary), returning the number selected,
3903 and setting the first elements of SYMS items. Error if no symbols
3904 selected. */
14f9c5c9
AS
3905
3906/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3907 to be re-integrated one of these days. */
14f9c5c9
AS
3908
3909int
d12307c1 3910user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3911{
3912 int i;
8d749320 3913 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3914 int n_chosen;
3915 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3916 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3917
3918 if (max_results < 1)
323e0a4a 3919 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3920 if (nsyms <= 1)
3921 return nsyms;
3922
717d2f5a
JB
3923 if (select_mode == multiple_symbols_cancel)
3924 error (_("\
3925canceled because the command is ambiguous\n\
3926See set/show multiple-symbol."));
3927
3928 /* If select_mode is "all", then return all possible symbols.
3929 Only do that if more than one symbol can be selected, of course.
3930 Otherwise, display the menu as usual. */
3931 if (select_mode == multiple_symbols_all && max_results > 1)
3932 return nsyms;
3933
323e0a4a 3934 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3935 if (max_results > 1)
323e0a4a 3936 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3937
4c4b4cd2 3938 sort_choices (syms, nsyms);
14f9c5c9
AS
3939
3940 for (i = 0; i < nsyms; i += 1)
3941 {
d12307c1 3942 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3943 continue;
3944
d12307c1 3945 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3946 {
76a01679 3947 struct symtab_and_line sal =
d12307c1 3948 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3949
d72413e6
PMR
3950 printf_unfiltered ("[%d] ", i + first_choice);
3951 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3952 &type_print_raw_options);
323e0a4a 3953 if (sal.symtab == NULL)
d72413e6 3954 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3955 sal.line);
3956 else
d72413e6 3957 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3958 symtab_to_filename_for_display (sal.symtab),
3959 sal.line);
4c4b4cd2
PH
3960 continue;
3961 }
d2e4a39e 3962 else
4c4b4cd2
PH
3963 {
3964 int is_enumeral =
d12307c1
PMR
3965 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3966 && SYMBOL_TYPE (syms[i].symbol) != NULL
3967 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3968 struct symtab *symtab = NULL;
3969
d12307c1
PMR
3970 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3971 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3972
d12307c1 3973 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3974 {
3975 printf_unfiltered ("[%d] ", i + first_choice);
3976 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3977 &type_print_raw_options);
3978 printf_unfiltered (_(" at %s:%d\n"),
3979 symtab_to_filename_for_display (symtab),
3980 SYMBOL_LINE (syms[i].symbol));
3981 }
76a01679 3982 else if (is_enumeral
d12307c1 3983 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3984 {
a3f17187 3985 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3986 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3987 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3988 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3989 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3990 }
d72413e6
PMR
3991 else
3992 {
3993 printf_unfiltered ("[%d] ", i + first_choice);
3994 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3995 &type_print_raw_options);
3996
3997 if (symtab != NULL)
3998 printf_unfiltered (is_enumeral
3999 ? _(" in %s (enumeral)\n")
4000 : _(" at %s:?\n"),
4001 symtab_to_filename_for_display (symtab));
4002 else
4003 printf_unfiltered (is_enumeral
4004 ? _(" (enumeral)\n")
4005 : _(" at ?\n"));
4006 }
4c4b4cd2 4007 }
14f9c5c9 4008 }
d2e4a39e 4009
14f9c5c9 4010 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4011 "overload-choice");
14f9c5c9
AS
4012
4013 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4014 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4015
4016 return n_chosen;
4017}
4018
4019/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4020 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4021 order in CHOICES[0 .. N-1], and return N.
4022
4023 The user types choices as a sequence of numbers on one line
4024 separated by blanks, encoding them as follows:
4025
4c4b4cd2 4026 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4027 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4028 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4029
4c4b4cd2 4030 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4031
4032 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4033 prompts (for use with the -f switch). */
14f9c5c9
AS
4034
4035int
d2e4a39e 4036get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4037 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4038{
d2e4a39e 4039 char *args;
a121b7c1 4040 const char *prompt;
14f9c5c9
AS
4041 int n_chosen;
4042 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4043
14f9c5c9
AS
4044 prompt = getenv ("PS2");
4045 if (prompt == NULL)
0bcd0149 4046 prompt = "> ";
14f9c5c9 4047
0bcd0149 4048 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 4049
14f9c5c9 4050 if (args == NULL)
323e0a4a 4051 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4052
4053 n_chosen = 0;
76a01679 4054
4c4b4cd2
PH
4055 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4056 order, as given in args. Choices are validated. */
14f9c5c9
AS
4057 while (1)
4058 {
d2e4a39e 4059 char *args2;
14f9c5c9
AS
4060 int choice, j;
4061
0fcd72ba 4062 args = skip_spaces (args);
14f9c5c9 4063 if (*args == '\0' && n_chosen == 0)
323e0a4a 4064 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4065 else if (*args == '\0')
4c4b4cd2 4066 break;
14f9c5c9
AS
4067
4068 choice = strtol (args, &args2, 10);
d2e4a39e 4069 if (args == args2 || choice < 0
4c4b4cd2 4070 || choice > n_choices + first_choice - 1)
323e0a4a 4071 error (_("Argument must be choice number"));
14f9c5c9
AS
4072 args = args2;
4073
d2e4a39e 4074 if (choice == 0)
323e0a4a 4075 error (_("cancelled"));
14f9c5c9
AS
4076
4077 if (choice < first_choice)
4c4b4cd2
PH
4078 {
4079 n_chosen = n_choices;
4080 for (j = 0; j < n_choices; j += 1)
4081 choices[j] = j;
4082 break;
4083 }
14f9c5c9
AS
4084 choice -= first_choice;
4085
d2e4a39e 4086 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4087 {
4088 }
14f9c5c9
AS
4089
4090 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4091 {
4092 int k;
5b4ee69b 4093
4c4b4cd2
PH
4094 for (k = n_chosen - 1; k > j; k -= 1)
4095 choices[k + 1] = choices[k];
4096 choices[j + 1] = choice;
4097 n_chosen += 1;
4098 }
14f9c5c9
AS
4099 }
4100
4101 if (n_chosen > max_results)
323e0a4a 4102 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4103
14f9c5c9
AS
4104 return n_chosen;
4105}
4106
4c4b4cd2
PH
4107/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4108 on the function identified by SYM and BLOCK, and taking NARGS
4109 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4110
4111static void
d2e4a39e 4112replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 4113 int oplen, struct symbol *sym,
270140bd 4114 const struct block *block)
14f9c5c9
AS
4115{
4116 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4117 symbol, -oplen for operator being replaced). */
d2e4a39e 4118 struct expression *newexp = (struct expression *)
8c1a34e7 4119 xzalloc (sizeof (struct expression)
4c4b4cd2 4120 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 4121 struct expression *exp = *expp;
14f9c5c9
AS
4122
4123 newexp->nelts = exp->nelts + 7 - oplen;
4124 newexp->language_defn = exp->language_defn;
3489610d 4125 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4126 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4127 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4128 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4129
4130 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4131 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4132
4133 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4134 newexp->elts[pc + 4].block = block;
4135 newexp->elts[pc + 5].symbol = sym;
4136
4137 *expp = newexp;
aacb1f0a 4138 xfree (exp);
d2e4a39e 4139}
14f9c5c9
AS
4140
4141/* Type-class predicates */
4142
4c4b4cd2
PH
4143/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4144 or FLOAT). */
14f9c5c9
AS
4145
4146static int
d2e4a39e 4147numeric_type_p (struct type *type)
14f9c5c9
AS
4148{
4149 if (type == NULL)
4150 return 0;
d2e4a39e
AS
4151 else
4152 {
4153 switch (TYPE_CODE (type))
4c4b4cd2
PH
4154 {
4155 case TYPE_CODE_INT:
4156 case TYPE_CODE_FLT:
4157 return 1;
4158 case TYPE_CODE_RANGE:
4159 return (type == TYPE_TARGET_TYPE (type)
4160 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4161 default:
4162 return 0;
4163 }
d2e4a39e 4164 }
14f9c5c9
AS
4165}
4166
4c4b4cd2 4167/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4168
4169static int
d2e4a39e 4170integer_type_p (struct type *type)
14f9c5c9
AS
4171{
4172 if (type == NULL)
4173 return 0;
d2e4a39e
AS
4174 else
4175 {
4176 switch (TYPE_CODE (type))
4c4b4cd2
PH
4177 {
4178 case TYPE_CODE_INT:
4179 return 1;
4180 case TYPE_CODE_RANGE:
4181 return (type == TYPE_TARGET_TYPE (type)
4182 || integer_type_p (TYPE_TARGET_TYPE (type)));
4183 default:
4184 return 0;
4185 }
d2e4a39e 4186 }
14f9c5c9
AS
4187}
4188
4c4b4cd2 4189/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4190
4191static int
d2e4a39e 4192scalar_type_p (struct type *type)
14f9c5c9
AS
4193{
4194 if (type == NULL)
4195 return 0;
d2e4a39e
AS
4196 else
4197 {
4198 switch (TYPE_CODE (type))
4c4b4cd2
PH
4199 {
4200 case TYPE_CODE_INT:
4201 case TYPE_CODE_RANGE:
4202 case TYPE_CODE_ENUM:
4203 case TYPE_CODE_FLT:
4204 return 1;
4205 default:
4206 return 0;
4207 }
d2e4a39e 4208 }
14f9c5c9
AS
4209}
4210
4c4b4cd2 4211/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4212
4213static int
d2e4a39e 4214discrete_type_p (struct type *type)
14f9c5c9
AS
4215{
4216 if (type == NULL)
4217 return 0;
d2e4a39e
AS
4218 else
4219 {
4220 switch (TYPE_CODE (type))
4c4b4cd2
PH
4221 {
4222 case TYPE_CODE_INT:
4223 case TYPE_CODE_RANGE:
4224 case TYPE_CODE_ENUM:
872f0337 4225 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4226 return 1;
4227 default:
4228 return 0;
4229 }
d2e4a39e 4230 }
14f9c5c9
AS
4231}
4232
4c4b4cd2
PH
4233/* Returns non-zero if OP with operands in the vector ARGS could be
4234 a user-defined function. Errs on the side of pre-defined operators
4235 (i.e., result 0). */
14f9c5c9
AS
4236
4237static int
d2e4a39e 4238possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4239{
76a01679 4240 struct type *type0 =
df407dfe 4241 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4242 struct type *type1 =
df407dfe 4243 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4244
4c4b4cd2
PH
4245 if (type0 == NULL)
4246 return 0;
4247
14f9c5c9
AS
4248 switch (op)
4249 {
4250 default:
4251 return 0;
4252
4253 case BINOP_ADD:
4254 case BINOP_SUB:
4255 case BINOP_MUL:
4256 case BINOP_DIV:
d2e4a39e 4257 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4258
4259 case BINOP_REM:
4260 case BINOP_MOD:
4261 case BINOP_BITWISE_AND:
4262 case BINOP_BITWISE_IOR:
4263 case BINOP_BITWISE_XOR:
d2e4a39e 4264 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4265
4266 case BINOP_EQUAL:
4267 case BINOP_NOTEQUAL:
4268 case BINOP_LESS:
4269 case BINOP_GTR:
4270 case BINOP_LEQ:
4271 case BINOP_GEQ:
d2e4a39e 4272 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4273
4274 case BINOP_CONCAT:
ee90b9ab 4275 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4276
4277 case BINOP_EXP:
d2e4a39e 4278 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4279
4280 case UNOP_NEG:
4281 case UNOP_PLUS:
4282 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4283 case UNOP_ABS:
4284 return (!numeric_type_p (type0));
14f9c5c9
AS
4285
4286 }
4287}
4288\f
4c4b4cd2 4289 /* Renaming */
14f9c5c9 4290
aeb5907d
JB
4291/* NOTES:
4292
4293 1. In the following, we assume that a renaming type's name may
4294 have an ___XD suffix. It would be nice if this went away at some
4295 point.
4296 2. We handle both the (old) purely type-based representation of
4297 renamings and the (new) variable-based encoding. At some point,
4298 it is devoutly to be hoped that the former goes away
4299 (FIXME: hilfinger-2007-07-09).
4300 3. Subprogram renamings are not implemented, although the XRS
4301 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4302
4303/* If SYM encodes a renaming,
4304
4305 <renaming> renames <renamed entity>,
4306
4307 sets *LEN to the length of the renamed entity's name,
4308 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4309 the string describing the subcomponent selected from the renamed
0963b4bd 4310 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4311 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4312 are undefined). Otherwise, returns a value indicating the category
4313 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4314 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4315 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4316 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4317 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4318 may be NULL, in which case they are not assigned.
4319
4320 [Currently, however, GCC does not generate subprogram renamings.] */
4321
4322enum ada_renaming_category
4323ada_parse_renaming (struct symbol *sym,
4324 const char **renamed_entity, int *len,
4325 const char **renaming_expr)
4326{
4327 enum ada_renaming_category kind;
4328 const char *info;
4329 const char *suffix;
4330
4331 if (sym == NULL)
4332 return ADA_NOT_RENAMING;
4333 switch (SYMBOL_CLASS (sym))
14f9c5c9 4334 {
aeb5907d
JB
4335 default:
4336 return ADA_NOT_RENAMING;
4337 case LOC_TYPEDEF:
4338 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4339 renamed_entity, len, renaming_expr);
4340 case LOC_LOCAL:
4341 case LOC_STATIC:
4342 case LOC_COMPUTED:
4343 case LOC_OPTIMIZED_OUT:
4344 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4345 if (info == NULL)
4346 return ADA_NOT_RENAMING;
4347 switch (info[5])
4348 {
4349 case '_':
4350 kind = ADA_OBJECT_RENAMING;
4351 info += 6;
4352 break;
4353 case 'E':
4354 kind = ADA_EXCEPTION_RENAMING;
4355 info += 7;
4356 break;
4357 case 'P':
4358 kind = ADA_PACKAGE_RENAMING;
4359 info += 7;
4360 break;
4361 case 'S':
4362 kind = ADA_SUBPROGRAM_RENAMING;
4363 info += 7;
4364 break;
4365 default:
4366 return ADA_NOT_RENAMING;
4367 }
14f9c5c9 4368 }
4c4b4cd2 4369
aeb5907d
JB
4370 if (renamed_entity != NULL)
4371 *renamed_entity = info;
4372 suffix = strstr (info, "___XE");
4373 if (suffix == NULL || suffix == info)
4374 return ADA_NOT_RENAMING;
4375 if (len != NULL)
4376 *len = strlen (info) - strlen (suffix);
4377 suffix += 5;
4378 if (renaming_expr != NULL)
4379 *renaming_expr = suffix;
4380 return kind;
4381}
4382
4383/* Assuming TYPE encodes a renaming according to the old encoding in
4384 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4385 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4386 ADA_NOT_RENAMING otherwise. */
4387static enum ada_renaming_category
4388parse_old_style_renaming (struct type *type,
4389 const char **renamed_entity, int *len,
4390 const char **renaming_expr)
4391{
4392 enum ada_renaming_category kind;
4393 const char *name;
4394 const char *info;
4395 const char *suffix;
14f9c5c9 4396
aeb5907d
JB
4397 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4398 || TYPE_NFIELDS (type) != 1)
4399 return ADA_NOT_RENAMING;
14f9c5c9 4400
aeb5907d
JB
4401 name = type_name_no_tag (type);
4402 if (name == NULL)
4403 return ADA_NOT_RENAMING;
4404
4405 name = strstr (name, "___XR");
4406 if (name == NULL)
4407 return ADA_NOT_RENAMING;
4408 switch (name[5])
4409 {
4410 case '\0':
4411 case '_':
4412 kind = ADA_OBJECT_RENAMING;
4413 break;
4414 case 'E':
4415 kind = ADA_EXCEPTION_RENAMING;
4416 break;
4417 case 'P':
4418 kind = ADA_PACKAGE_RENAMING;
4419 break;
4420 case 'S':
4421 kind = ADA_SUBPROGRAM_RENAMING;
4422 break;
4423 default:
4424 return ADA_NOT_RENAMING;
4425 }
14f9c5c9 4426
aeb5907d
JB
4427 info = TYPE_FIELD_NAME (type, 0);
4428 if (info == NULL)
4429 return ADA_NOT_RENAMING;
4430 if (renamed_entity != NULL)
4431 *renamed_entity = info;
4432 suffix = strstr (info, "___XE");
4433 if (renaming_expr != NULL)
4434 *renaming_expr = suffix + 5;
4435 if (suffix == NULL || suffix == info)
4436 return ADA_NOT_RENAMING;
4437 if (len != NULL)
4438 *len = suffix - info;
4439 return kind;
a5ee536b
JB
4440}
4441
4442/* Compute the value of the given RENAMING_SYM, which is expected to
4443 be a symbol encoding a renaming expression. BLOCK is the block
4444 used to evaluate the renaming. */
52ce6436 4445
a5ee536b
JB
4446static struct value *
4447ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4448 const struct block *block)
a5ee536b 4449{
bbc13ae3 4450 const char *sym_name;
a5ee536b 4451
bbc13ae3 4452 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4453 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4454 return evaluate_expression (expr.get ());
a5ee536b 4455}
14f9c5c9 4456\f
d2e4a39e 4457
4c4b4cd2 4458 /* Evaluation: Function Calls */
14f9c5c9 4459
4c4b4cd2 4460/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4461 lvalues, and otherwise has the side-effect of allocating memory
4462 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4463
d2e4a39e 4464static struct value *
40bc484c 4465ensure_lval (struct value *val)
14f9c5c9 4466{
40bc484c
JB
4467 if (VALUE_LVAL (val) == not_lval
4468 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4469 {
df407dfe 4470 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4471 const CORE_ADDR addr =
4472 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4473
a84a8a0d 4474 VALUE_LVAL (val) = lval_memory;
1a088441 4475 set_value_address (val, addr);
40bc484c 4476 write_memory (addr, value_contents (val), len);
c3e5cd34 4477 }
14f9c5c9
AS
4478
4479 return val;
4480}
4481
4482/* Return the value ACTUAL, converted to be an appropriate value for a
4483 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4484 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4485 values not residing in memory, updating it as needed. */
14f9c5c9 4486
a93c0eb6 4487struct value *
40bc484c 4488ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4489{
df407dfe 4490 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4491 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4492 struct type *formal_target =
4493 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4494 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4495 struct type *actual_target =
4496 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4497 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4498
4c4b4cd2 4499 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4500 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4501 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4502 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4503 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4504 {
a84a8a0d 4505 struct value *result;
5b4ee69b 4506
14f9c5c9 4507 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4508 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4509 result = desc_data (actual);
14f9c5c9 4510 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4511 {
4512 if (VALUE_LVAL (actual) != lval_memory)
4513 {
4514 struct value *val;
5b4ee69b 4515
df407dfe 4516 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4517 val = allocate_value (actual_type);
990a07ab 4518 memcpy ((char *) value_contents_raw (val),
0fd88904 4519 (char *) value_contents (actual),
4c4b4cd2 4520 TYPE_LENGTH (actual_type));
40bc484c 4521 actual = ensure_lval (val);
4c4b4cd2 4522 }
a84a8a0d 4523 result = value_addr (actual);
4c4b4cd2 4524 }
a84a8a0d
JB
4525 else
4526 return actual;
b1af9e97 4527 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4528 }
4529 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4530 return ada_value_ind (actual);
8344af1e
JB
4531 else if (ada_is_aligner_type (formal_type))
4532 {
4533 /* We need to turn this parameter into an aligner type
4534 as well. */
4535 struct value *aligner = allocate_value (formal_type);
4536 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4537
4538 value_assign_to_component (aligner, component, actual);
4539 return aligner;
4540 }
14f9c5c9
AS
4541
4542 return actual;
4543}
4544
438c98a1
JB
4545/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4546 type TYPE. This is usually an inefficient no-op except on some targets
4547 (such as AVR) where the representation of a pointer and an address
4548 differs. */
4549
4550static CORE_ADDR
4551value_pointer (struct value *value, struct type *type)
4552{
4553 struct gdbarch *gdbarch = get_type_arch (type);
4554 unsigned len = TYPE_LENGTH (type);
224c3ddb 4555 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4556 CORE_ADDR addr;
4557
4558 addr = value_address (value);
4559 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4560 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4561 return addr;
4562}
4563
14f9c5c9 4564
4c4b4cd2
PH
4565/* Push a descriptor of type TYPE for array value ARR on the stack at
4566 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4567 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4568 to-descriptor type rather than a descriptor type), a struct value *
4569 representing a pointer to this descriptor. */
14f9c5c9 4570
d2e4a39e 4571static struct value *
40bc484c 4572make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4573{
d2e4a39e
AS
4574 struct type *bounds_type = desc_bounds_type (type);
4575 struct type *desc_type = desc_base_type (type);
4576 struct value *descriptor = allocate_value (desc_type);
4577 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4578 int i;
d2e4a39e 4579
0963b4bd
MS
4580 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4581 i > 0; i -= 1)
14f9c5c9 4582 {
19f220c3
JK
4583 modify_field (value_type (bounds), value_contents_writeable (bounds),
4584 ada_array_bound (arr, i, 0),
4585 desc_bound_bitpos (bounds_type, i, 0),
4586 desc_bound_bitsize (bounds_type, i, 0));
4587 modify_field (value_type (bounds), value_contents_writeable (bounds),
4588 ada_array_bound (arr, i, 1),
4589 desc_bound_bitpos (bounds_type, i, 1),
4590 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4591 }
d2e4a39e 4592
40bc484c 4593 bounds = ensure_lval (bounds);
d2e4a39e 4594
19f220c3
JK
4595 modify_field (value_type (descriptor),
4596 value_contents_writeable (descriptor),
4597 value_pointer (ensure_lval (arr),
4598 TYPE_FIELD_TYPE (desc_type, 0)),
4599 fat_pntr_data_bitpos (desc_type),
4600 fat_pntr_data_bitsize (desc_type));
4601
4602 modify_field (value_type (descriptor),
4603 value_contents_writeable (descriptor),
4604 value_pointer (bounds,
4605 TYPE_FIELD_TYPE (desc_type, 1)),
4606 fat_pntr_bounds_bitpos (desc_type),
4607 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4608
40bc484c 4609 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4610
4611 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4612 return value_addr (descriptor);
4613 else
4614 return descriptor;
4615}
14f9c5c9 4616\f
3d9434b5
JB
4617 /* Symbol Cache Module */
4618
3d9434b5 4619/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4620 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4621 on the type of entity being printed, the cache can make it as much
4622 as an order of magnitude faster than without it.
4623
4624 The descriptive type DWARF extension has significantly reduced
4625 the need for this cache, at least when DWARF is being used. However,
4626 even in this case, some expensive name-based symbol searches are still
4627 sometimes necessary - to find an XVZ variable, mostly. */
4628
ee01b665 4629/* Initialize the contents of SYM_CACHE. */
3d9434b5 4630
ee01b665
JB
4631static void
4632ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4633{
4634 obstack_init (&sym_cache->cache_space);
4635 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4636}
3d9434b5 4637
ee01b665
JB
4638/* Free the memory used by SYM_CACHE. */
4639
4640static void
4641ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4642{
ee01b665
JB
4643 obstack_free (&sym_cache->cache_space, NULL);
4644 xfree (sym_cache);
4645}
3d9434b5 4646
ee01b665
JB
4647/* Return the symbol cache associated to the given program space PSPACE.
4648 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4649
ee01b665
JB
4650static struct ada_symbol_cache *
4651ada_get_symbol_cache (struct program_space *pspace)
4652{
4653 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4654
66c168ae 4655 if (pspace_data->sym_cache == NULL)
ee01b665 4656 {
66c168ae
JB
4657 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4658 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4659 }
4660
66c168ae 4661 return pspace_data->sym_cache;
ee01b665 4662}
3d9434b5
JB
4663
4664/* Clear all entries from the symbol cache. */
4665
4666static void
4667ada_clear_symbol_cache (void)
4668{
ee01b665
JB
4669 struct ada_symbol_cache *sym_cache
4670 = ada_get_symbol_cache (current_program_space);
4671
4672 obstack_free (&sym_cache->cache_space, NULL);
4673 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4674}
4675
fe978cb0 4676/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4677 Return it if found, or NULL otherwise. */
4678
4679static struct cache_entry **
fe978cb0 4680find_entry (const char *name, domain_enum domain)
3d9434b5 4681{
ee01b665
JB
4682 struct ada_symbol_cache *sym_cache
4683 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4684 int h = msymbol_hash (name) % HASH_SIZE;
4685 struct cache_entry **e;
4686
ee01b665 4687 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4688 {
fe978cb0 4689 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4690 return e;
4691 }
4692 return NULL;
4693}
4694
fe978cb0 4695/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4696 Return 1 if found, 0 otherwise.
4697
4698 If an entry was found and SYM is not NULL, set *SYM to the entry's
4699 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4700
96d887e8 4701static int
fe978cb0 4702lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4703 struct symbol **sym, const struct block **block)
96d887e8 4704{
fe978cb0 4705 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4706
4707 if (e == NULL)
4708 return 0;
4709 if (sym != NULL)
4710 *sym = (*e)->sym;
4711 if (block != NULL)
4712 *block = (*e)->block;
4713 return 1;
96d887e8
PH
4714}
4715
3d9434b5 4716/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4717 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4718
96d887e8 4719static void
fe978cb0 4720cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4721 const struct block *block)
96d887e8 4722{
ee01b665
JB
4723 struct ada_symbol_cache *sym_cache
4724 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4725 int h;
4726 char *copy;
4727 struct cache_entry *e;
4728
1994afbf
DE
4729 /* Symbols for builtin types don't have a block.
4730 For now don't cache such symbols. */
4731 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4732 return;
4733
3d9434b5
JB
4734 /* If the symbol is a local symbol, then do not cache it, as a search
4735 for that symbol depends on the context. To determine whether
4736 the symbol is local or not, we check the block where we found it
4737 against the global and static blocks of its associated symtab. */
4738 if (sym
08be3fe3 4739 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4740 GLOBAL_BLOCK) != block
08be3fe3 4741 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4742 STATIC_BLOCK) != block)
3d9434b5
JB
4743 return;
4744
4745 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4746 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4747 sizeof (*e));
4748 e->next = sym_cache->root[h];
4749 sym_cache->root[h] = e;
224c3ddb
SM
4750 e->name = copy
4751 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4752 strcpy (copy, name);
4753 e->sym = sym;
fe978cb0 4754 e->domain = domain;
3d9434b5 4755 e->block = block;
96d887e8 4756}
4c4b4cd2
PH
4757\f
4758 /* Symbol Lookup */
4759
c0431670
JB
4760/* Return nonzero if wild matching should be used when searching for
4761 all symbols matching LOOKUP_NAME.
4762
4763 LOOKUP_NAME is expected to be a symbol name after transformation
4764 for Ada lookups (see ada_name_for_lookup). */
4765
4766static int
4767should_use_wild_match (const char *lookup_name)
4768{
4769 return (strstr (lookup_name, "__") == NULL);
4770}
4771
4c4b4cd2
PH
4772/* Return the result of a standard (literal, C-like) lookup of NAME in
4773 given DOMAIN, visible from lexical block BLOCK. */
4774
4775static struct symbol *
4776standard_lookup (const char *name, const struct block *block,
4777 domain_enum domain)
4778{
acbd605d 4779 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4780 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4781
d12307c1
PMR
4782 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4783 return sym.symbol;
2570f2b7 4784 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4785 cache_symbol (name, domain, sym.symbol, sym.block);
4786 return sym.symbol;
4c4b4cd2
PH
4787}
4788
4789
4790/* Non-zero iff there is at least one non-function/non-enumeral symbol
4791 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4792 since they contend in overloading in the same way. */
4793static int
d12307c1 4794is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4795{
4796 int i;
4797
4798 for (i = 0; i < n; i += 1)
d12307c1
PMR
4799 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4800 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4801 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4802 return 1;
4803
4804 return 0;
4805}
4806
4807/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4808 struct types. Otherwise, they may not. */
14f9c5c9
AS
4809
4810static int
d2e4a39e 4811equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4812{
d2e4a39e 4813 if (type0 == type1)
14f9c5c9 4814 return 1;
d2e4a39e 4815 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4816 || TYPE_CODE (type0) != TYPE_CODE (type1))
4817 return 0;
d2e4a39e 4818 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4819 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4820 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4821 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4822 return 1;
d2e4a39e 4823
14f9c5c9
AS
4824 return 0;
4825}
4826
4827/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4828 no more defined than that of SYM1. */
14f9c5c9
AS
4829
4830static int
d2e4a39e 4831lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4832{
4833 if (sym0 == sym1)
4834 return 1;
176620f1 4835 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4836 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4837 return 0;
4838
d2e4a39e 4839 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4840 {
4841 case LOC_UNDEF:
4842 return 1;
4843 case LOC_TYPEDEF:
4844 {
4c4b4cd2
PH
4845 struct type *type0 = SYMBOL_TYPE (sym0);
4846 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4847 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4848 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4849 int len0 = strlen (name0);
5b4ee69b 4850
4c4b4cd2
PH
4851 return
4852 TYPE_CODE (type0) == TYPE_CODE (type1)
4853 && (equiv_types (type0, type1)
4854 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4855 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4856 }
4857 case LOC_CONST:
4858 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4859 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4860 default:
4861 return 0;
14f9c5c9
AS
4862 }
4863}
4864
d12307c1 4865/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4866 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4867
4868static void
76a01679
JB
4869add_defn_to_vec (struct obstack *obstackp,
4870 struct symbol *sym,
f0c5f9b2 4871 const struct block *block)
14f9c5c9
AS
4872{
4873 int i;
d12307c1 4874 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4875
529cad9c
PH
4876 /* Do not try to complete stub types, as the debugger is probably
4877 already scanning all symbols matching a certain name at the
4878 time when this function is called. Trying to replace the stub
4879 type by its associated full type will cause us to restart a scan
4880 which may lead to an infinite recursion. Instead, the client
4881 collecting the matching symbols will end up collecting several
4882 matches, with at least one of them complete. It can then filter
4883 out the stub ones if needed. */
4884
4c4b4cd2
PH
4885 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4886 {
d12307c1 4887 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4888 return;
d12307c1 4889 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4890 {
d12307c1 4891 prevDefns[i].symbol = sym;
4c4b4cd2 4892 prevDefns[i].block = block;
4c4b4cd2 4893 return;
76a01679 4894 }
4c4b4cd2
PH
4895 }
4896
4897 {
d12307c1 4898 struct block_symbol info;
4c4b4cd2 4899
d12307c1 4900 info.symbol = sym;
4c4b4cd2 4901 info.block = block;
d12307c1 4902 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4903 }
4904}
4905
d12307c1
PMR
4906/* Number of block_symbol structures currently collected in current vector in
4907 OBSTACKP. */
4c4b4cd2 4908
76a01679
JB
4909static int
4910num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4911{
d12307c1 4912 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4913}
4914
d12307c1
PMR
4915/* Vector of block_symbol structures currently collected in current vector in
4916 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4917
d12307c1 4918static struct block_symbol *
4c4b4cd2
PH
4919defns_collected (struct obstack *obstackp, int finish)
4920{
4921 if (finish)
224c3ddb 4922 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4923 else
d12307c1 4924 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4925}
4926
7c7b6655
TT
4927/* Return a bound minimal symbol matching NAME according to Ada
4928 decoding rules. Returns an invalid symbol if there is no such
4929 minimal symbol. Names prefixed with "standard__" are handled
4930 specially: "standard__" is first stripped off, and only static and
4931 global symbols are searched. */
4c4b4cd2 4932
7c7b6655 4933struct bound_minimal_symbol
96d887e8 4934ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4935{
7c7b6655 4936 struct bound_minimal_symbol result;
4c4b4cd2 4937 struct objfile *objfile;
96d887e8 4938 struct minimal_symbol *msymbol;
dc4024cd 4939 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4940
7c7b6655
TT
4941 memset (&result, 0, sizeof (result));
4942
c0431670
JB
4943 /* Special case: If the user specifies a symbol name inside package
4944 Standard, do a non-wild matching of the symbol name without
4945 the "standard__" prefix. This was primarily introduced in order
4946 to allow the user to specifically access the standard exceptions
4947 using, for instance, Standard.Constraint_Error when Constraint_Error
4948 is ambiguous (due to the user defining its own Constraint_Error
4949 entity inside its program). */
61012eef 4950 if (startswith (name, "standard__"))
c0431670 4951 name += sizeof ("standard__") - 1;
4c4b4cd2 4952
96d887e8
PH
4953 ALL_MSYMBOLS (objfile, msymbol)
4954 {
efd66ac6 4955 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4956 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4957 {
4958 result.minsym = msymbol;
4959 result.objfile = objfile;
4960 break;
4961 }
96d887e8 4962 }
4c4b4cd2 4963
7c7b6655 4964 return result;
96d887e8 4965}
4c4b4cd2 4966
96d887e8
PH
4967/* For all subprograms that statically enclose the subprogram of the
4968 selected frame, add symbols matching identifier NAME in DOMAIN
4969 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4970 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4971 with a wildcard prefix. */
4c4b4cd2 4972
96d887e8
PH
4973static void
4974add_symbols_from_enclosing_procs (struct obstack *obstackp,
fe978cb0 4975 const char *name, domain_enum domain,
48b78332 4976 int wild_match_p)
96d887e8 4977{
96d887e8 4978}
14f9c5c9 4979
96d887e8
PH
4980/* True if TYPE is definitely an artificial type supplied to a symbol
4981 for which no debugging information was given in the symbol file. */
14f9c5c9 4982
96d887e8
PH
4983static int
4984is_nondebugging_type (struct type *type)
4985{
0d5cff50 4986 const char *name = ada_type_name (type);
5b4ee69b 4987
96d887e8
PH
4988 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4989}
4c4b4cd2 4990
8f17729f
JB
4991/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4992 that are deemed "identical" for practical purposes.
4993
4994 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4995 types and that their number of enumerals is identical (in other
4996 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4997
4998static int
4999ada_identical_enum_types_p (struct type *type1, struct type *type2)
5000{
5001 int i;
5002
5003 /* The heuristic we use here is fairly conservative. We consider
5004 that 2 enumerate types are identical if they have the same
5005 number of enumerals and that all enumerals have the same
5006 underlying value and name. */
5007
5008 /* All enums in the type should have an identical underlying value. */
5009 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 5010 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
5011 return 0;
5012
5013 /* All enumerals should also have the same name (modulo any numerical
5014 suffix). */
5015 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5016 {
0d5cff50
DE
5017 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5018 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5019 int len_1 = strlen (name_1);
5020 int len_2 = strlen (name_2);
5021
5022 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5023 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5024 if (len_1 != len_2
5025 || strncmp (TYPE_FIELD_NAME (type1, i),
5026 TYPE_FIELD_NAME (type2, i),
5027 len_1) != 0)
5028 return 0;
5029 }
5030
5031 return 1;
5032}
5033
5034/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5035 that are deemed "identical" for practical purposes. Sometimes,
5036 enumerals are not strictly identical, but their types are so similar
5037 that they can be considered identical.
5038
5039 For instance, consider the following code:
5040
5041 type Color is (Black, Red, Green, Blue, White);
5042 type RGB_Color is new Color range Red .. Blue;
5043
5044 Type RGB_Color is a subrange of an implicit type which is a copy
5045 of type Color. If we call that implicit type RGB_ColorB ("B" is
5046 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5047 As a result, when an expression references any of the enumeral
5048 by name (Eg. "print green"), the expression is technically
5049 ambiguous and the user should be asked to disambiguate. But
5050 doing so would only hinder the user, since it wouldn't matter
5051 what choice he makes, the outcome would always be the same.
5052 So, for practical purposes, we consider them as the same. */
5053
5054static int
d12307c1 5055symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
8f17729f
JB
5056{
5057 int i;
5058
5059 /* Before performing a thorough comparison check of each type,
5060 we perform a series of inexpensive checks. We expect that these
5061 checks will quickly fail in the vast majority of cases, and thus
5062 help prevent the unnecessary use of a more expensive comparison.
5063 Said comparison also expects us to make some of these checks
5064 (see ada_identical_enum_types_p). */
5065
5066 /* Quick check: All symbols should have an enum type. */
5067 for (i = 0; i < nsyms; i++)
d12307c1 5068 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5069 return 0;
5070
5071 /* Quick check: They should all have the same value. */
5072 for (i = 1; i < nsyms; i++)
d12307c1 5073 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5074 return 0;
5075
5076 /* Quick check: They should all have the same number of enumerals. */
5077 for (i = 1; i < nsyms; i++)
d12307c1
PMR
5078 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5079 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5080 return 0;
5081
5082 /* All the sanity checks passed, so we might have a set of
5083 identical enumeration types. Perform a more complete
5084 comparison of the type of each symbol. */
5085 for (i = 1; i < nsyms; i++)
d12307c1
PMR
5086 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5087 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5088 return 0;
5089
5090 return 1;
5091}
5092
96d887e8
PH
5093/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5094 duplicate other symbols in the list (The only case I know of where
5095 this happens is when object files containing stabs-in-ecoff are
5096 linked with files containing ordinary ecoff debugging symbols (or no
5097 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5098 Returns the number of items in the modified list. */
4c4b4cd2 5099
96d887e8 5100static int
d12307c1 5101remove_extra_symbols (struct block_symbol *syms, int nsyms)
96d887e8
PH
5102{
5103 int i, j;
4c4b4cd2 5104
8f17729f
JB
5105 /* We should never be called with less than 2 symbols, as there
5106 cannot be any extra symbol in that case. But it's easy to
5107 handle, since we have nothing to do in that case. */
5108 if (nsyms < 2)
5109 return nsyms;
5110
96d887e8
PH
5111 i = 0;
5112 while (i < nsyms)
5113 {
a35ddb44 5114 int remove_p = 0;
339c13b6
JB
5115
5116 /* If two symbols have the same name and one of them is a stub type,
5117 the get rid of the stub. */
5118
d12307c1
PMR
5119 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5120 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
339c13b6
JB
5121 {
5122 for (j = 0; j < nsyms; j++)
5123 {
5124 if (j != i
d12307c1
PMR
5125 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5126 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5127 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5128 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
a35ddb44 5129 remove_p = 1;
339c13b6
JB
5130 }
5131 }
5132
5133 /* Two symbols with the same name, same class and same address
5134 should be identical. */
5135
d12307c1
PMR
5136 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5137 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5138 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
96d887e8
PH
5139 {
5140 for (j = 0; j < nsyms; j += 1)
5141 {
5142 if (i != j
d12307c1
PMR
5143 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5144 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5145 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5146 && SYMBOL_CLASS (syms[i].symbol)
5147 == SYMBOL_CLASS (syms[j].symbol)
5148 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5149 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
a35ddb44 5150 remove_p = 1;
4c4b4cd2 5151 }
4c4b4cd2 5152 }
339c13b6 5153
a35ddb44 5154 if (remove_p)
339c13b6
JB
5155 {
5156 for (j = i + 1; j < nsyms; j += 1)
5157 syms[j - 1] = syms[j];
5158 nsyms -= 1;
5159 }
5160
96d887e8 5161 i += 1;
14f9c5c9 5162 }
8f17729f
JB
5163
5164 /* If all the remaining symbols are identical enumerals, then
5165 just keep the first one and discard the rest.
5166
5167 Unlike what we did previously, we do not discard any entry
5168 unless they are ALL identical. This is because the symbol
5169 comparison is not a strict comparison, but rather a practical
5170 comparison. If all symbols are considered identical, then
5171 we can just go ahead and use the first one and discard the rest.
5172 But if we cannot reduce the list to a single element, we have
5173 to ask the user to disambiguate anyways. And if we have to
5174 present a multiple-choice menu, it's less confusing if the list
5175 isn't missing some choices that were identical and yet distinct. */
5176 if (symbols_are_identical_enums (syms, nsyms))
5177 nsyms = 1;
5178
96d887e8 5179 return nsyms;
14f9c5c9
AS
5180}
5181
96d887e8
PH
5182/* Given a type that corresponds to a renaming entity, use the type name
5183 to extract the scope (package name or function name, fully qualified,
5184 and following the GNAT encoding convention) where this renaming has been
5185 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 5186
96d887e8
PH
5187static char *
5188xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5189{
96d887e8 5190 /* The renaming types adhere to the following convention:
0963b4bd 5191 <scope>__<rename>___<XR extension>.
96d887e8
PH
5192 So, to extract the scope, we search for the "___XR" extension,
5193 and then backtrack until we find the first "__". */
76a01679 5194
96d887e8 5195 const char *name = type_name_no_tag (renaming_type);
108d56a4
SM
5196 const char *suffix = strstr (name, "___XR");
5197 const char *last;
96d887e8
PH
5198 int scope_len;
5199 char *scope;
14f9c5c9 5200
96d887e8
PH
5201 /* Now, backtrack a bit until we find the first "__". Start looking
5202 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5203
96d887e8
PH
5204 for (last = suffix - 3; last > name; last--)
5205 if (last[0] == '_' && last[1] == '_')
5206 break;
76a01679 5207
96d887e8 5208 /* Make a copy of scope and return it. */
14f9c5c9 5209
96d887e8
PH
5210 scope_len = last - name;
5211 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 5212
96d887e8
PH
5213 strncpy (scope, name, scope_len);
5214 scope[scope_len] = '\0';
4c4b4cd2 5215
96d887e8 5216 return scope;
4c4b4cd2
PH
5217}
5218
96d887e8 5219/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5220
96d887e8
PH
5221static int
5222is_package_name (const char *name)
4c4b4cd2 5223{
96d887e8
PH
5224 /* Here, We take advantage of the fact that no symbols are generated
5225 for packages, while symbols are generated for each function.
5226 So the condition for NAME represent a package becomes equivalent
5227 to NAME not existing in our list of symbols. There is only one
5228 small complication with library-level functions (see below). */
4c4b4cd2 5229
96d887e8 5230 char *fun_name;
76a01679 5231
96d887e8
PH
5232 /* If it is a function that has not been defined at library level,
5233 then we should be able to look it up in the symbols. */
5234 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5235 return 0;
14f9c5c9 5236
96d887e8
PH
5237 /* Library-level function names start with "_ada_". See if function
5238 "_ada_" followed by NAME can be found. */
14f9c5c9 5239
96d887e8 5240 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5241 functions names cannot contain "__" in them. */
96d887e8
PH
5242 if (strstr (name, "__") != NULL)
5243 return 0;
4c4b4cd2 5244
b435e160 5245 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 5246
96d887e8
PH
5247 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5248}
14f9c5c9 5249
96d887e8 5250/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5251 not visible from FUNCTION_NAME. */
14f9c5c9 5252
96d887e8 5253static int
0d5cff50 5254old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5255{
aeb5907d 5256 char *scope;
1509e573 5257 struct cleanup *old_chain;
aeb5907d
JB
5258
5259 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5260 return 0;
5261
5262 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 5263 old_chain = make_cleanup (xfree, scope);
14f9c5c9 5264
96d887e8
PH
5265 /* If the rename has been defined in a package, then it is visible. */
5266 if (is_package_name (scope))
1509e573
JB
5267 {
5268 do_cleanups (old_chain);
5269 return 0;
5270 }
14f9c5c9 5271
96d887e8
PH
5272 /* Check that the rename is in the current function scope by checking
5273 that its name starts with SCOPE. */
76a01679 5274
96d887e8
PH
5275 /* If the function name starts with "_ada_", it means that it is
5276 a library-level function. Strip this prefix before doing the
5277 comparison, as the encoding for the renaming does not contain
5278 this prefix. */
61012eef 5279 if (startswith (function_name, "_ada_"))
96d887e8 5280 function_name += 5;
f26caa11 5281
1509e573 5282 {
61012eef 5283 int is_invisible = !startswith (function_name, scope);
1509e573
JB
5284
5285 do_cleanups (old_chain);
5286 return is_invisible;
5287 }
f26caa11
PH
5288}
5289
aeb5907d
JB
5290/* Remove entries from SYMS that corresponds to a renaming entity that
5291 is not visible from the function associated with CURRENT_BLOCK or
5292 that is superfluous due to the presence of more specific renaming
5293 information. Places surviving symbols in the initial entries of
5294 SYMS and returns the number of surviving symbols.
96d887e8
PH
5295
5296 Rationale:
aeb5907d
JB
5297 First, in cases where an object renaming is implemented as a
5298 reference variable, GNAT may produce both the actual reference
5299 variable and the renaming encoding. In this case, we discard the
5300 latter.
5301
5302 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5303 entity. Unfortunately, STABS currently does not support the definition
5304 of types that are local to a given lexical block, so all renamings types
5305 are emitted at library level. As a consequence, if an application
5306 contains two renaming entities using the same name, and a user tries to
5307 print the value of one of these entities, the result of the ada symbol
5308 lookup will also contain the wrong renaming type.
f26caa11 5309
96d887e8
PH
5310 This function partially covers for this limitation by attempting to
5311 remove from the SYMS list renaming symbols that should be visible
5312 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5313 method with the current information available. The implementation
5314 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5315
5316 - When the user tries to print a rename in a function while there
5317 is another rename entity defined in a package: Normally, the
5318 rename in the function has precedence over the rename in the
5319 package, so the latter should be removed from the list. This is
5320 currently not the case.
5321
5322 - This function will incorrectly remove valid renames if
5323 the CURRENT_BLOCK corresponds to a function which symbol name
5324 has been changed by an "Export" pragma. As a consequence,
5325 the user will be unable to print such rename entities. */
4c4b4cd2 5326
14f9c5c9 5327static int
d12307c1 5328remove_irrelevant_renamings (struct block_symbol *syms,
aeb5907d 5329 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5330{
5331 struct symbol *current_function;
0d5cff50 5332 const char *current_function_name;
4c4b4cd2 5333 int i;
aeb5907d
JB
5334 int is_new_style_renaming;
5335
5336 /* If there is both a renaming foo___XR... encoded as a variable and
5337 a simple variable foo in the same block, discard the latter.
0963b4bd 5338 First, zero out such symbols, then compress. */
aeb5907d
JB
5339 is_new_style_renaming = 0;
5340 for (i = 0; i < nsyms; i += 1)
5341 {
d12307c1 5342 struct symbol *sym = syms[i].symbol;
270140bd 5343 const struct block *block = syms[i].block;
aeb5907d
JB
5344 const char *name;
5345 const char *suffix;
5346
5347 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5348 continue;
5349 name = SYMBOL_LINKAGE_NAME (sym);
5350 suffix = strstr (name, "___XR");
5351
5352 if (suffix != NULL)
5353 {
5354 int name_len = suffix - name;
5355 int j;
5b4ee69b 5356
aeb5907d
JB
5357 is_new_style_renaming = 1;
5358 for (j = 0; j < nsyms; j += 1)
d12307c1
PMR
5359 if (i != j && syms[j].symbol != NULL
5360 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
aeb5907d
JB
5361 name_len) == 0
5362 && block == syms[j].block)
d12307c1 5363 syms[j].symbol = NULL;
aeb5907d
JB
5364 }
5365 }
5366 if (is_new_style_renaming)
5367 {
5368 int j, k;
5369
5370 for (j = k = 0; j < nsyms; j += 1)
d12307c1 5371 if (syms[j].symbol != NULL)
aeb5907d
JB
5372 {
5373 syms[k] = syms[j];
5374 k += 1;
5375 }
5376 return k;
5377 }
4c4b4cd2
PH
5378
5379 /* Extract the function name associated to CURRENT_BLOCK.
5380 Abort if unable to do so. */
76a01679 5381
4c4b4cd2
PH
5382 if (current_block == NULL)
5383 return nsyms;
76a01679 5384
7f0df278 5385 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5386 if (current_function == NULL)
5387 return nsyms;
5388
5389 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5390 if (current_function_name == NULL)
5391 return nsyms;
5392
5393 /* Check each of the symbols, and remove it from the list if it is
5394 a type corresponding to a renaming that is out of the scope of
5395 the current block. */
5396
5397 i = 0;
5398 while (i < nsyms)
5399 {
d12307c1 5400 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
aeb5907d 5401 == ADA_OBJECT_RENAMING
d12307c1 5402 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
4c4b4cd2
PH
5403 {
5404 int j;
5b4ee69b 5405
aeb5907d 5406 for (j = i + 1; j < nsyms; j += 1)
76a01679 5407 syms[j - 1] = syms[j];
4c4b4cd2
PH
5408 nsyms -= 1;
5409 }
5410 else
5411 i += 1;
5412 }
5413
5414 return nsyms;
5415}
5416
339c13b6
JB
5417/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5418 whose name and domain match NAME and DOMAIN respectively.
5419 If no match was found, then extend the search to "enclosing"
5420 routines (in other words, if we're inside a nested function,
5421 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5422 If WILD_MATCH_P is nonzero, perform the naming matching in
5423 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5424
5425 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5426
5427static void
5428ada_add_local_symbols (struct obstack *obstackp, const char *name,
f0c5f9b2 5429 const struct block *block, domain_enum domain,
d0a8ab18 5430 int wild_match_p)
339c13b6
JB
5431{
5432 int block_depth = 0;
5433
5434 while (block != NULL)
5435 {
5436 block_depth += 1;
d0a8ab18
JB
5437 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5438 wild_match_p);
339c13b6
JB
5439
5440 /* If we found a non-function match, assume that's the one. */
5441 if (is_nonfunction (defns_collected (obstackp, 0),
5442 num_defns_collected (obstackp)))
5443 return;
5444
5445 block = BLOCK_SUPERBLOCK (block);
5446 }
5447
5448 /* If no luck so far, try to find NAME as a local symbol in some lexically
5449 enclosing subprogram. */
5450 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 5451 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
5452}
5453
ccefe4c4 5454/* An object of this type is used as the user_data argument when
40658b94 5455 calling the map_matching_symbols method. */
ccefe4c4 5456
40658b94 5457struct match_data
ccefe4c4 5458{
40658b94 5459 struct objfile *objfile;
ccefe4c4 5460 struct obstack *obstackp;
40658b94
PH
5461 struct symbol *arg_sym;
5462 int found_sym;
ccefe4c4
TT
5463};
5464
22cee43f 5465/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5466 to a list of symbols. DATA0 is a pointer to a struct match_data *
5467 containing the obstack that collects the symbol list, the file that SYM
5468 must come from, a flag indicating whether a non-argument symbol has
5469 been found in the current block, and the last argument symbol
5470 passed in SYM within the current block (if any). When SYM is null,
5471 marking the end of a block, the argument symbol is added if no
5472 other has been found. */
ccefe4c4 5473
40658b94
PH
5474static int
5475aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5476{
40658b94
PH
5477 struct match_data *data = (struct match_data *) data0;
5478
5479 if (sym == NULL)
5480 {
5481 if (!data->found_sym && data->arg_sym != NULL)
5482 add_defn_to_vec (data->obstackp,
5483 fixup_symbol_section (data->arg_sym, data->objfile),
5484 block);
5485 data->found_sym = 0;
5486 data->arg_sym = NULL;
5487 }
5488 else
5489 {
5490 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5491 return 0;
5492 else if (SYMBOL_IS_ARGUMENT (sym))
5493 data->arg_sym = sym;
5494 else
5495 {
5496 data->found_sym = 1;
5497 add_defn_to_vec (data->obstackp,
5498 fixup_symbol_section (sym, data->objfile),
5499 block);
5500 }
5501 }
5502 return 0;
5503}
5504
22cee43f
PMR
5505/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are targetted
5506 by renamings matching NAME in BLOCK. Add these symbols to OBSTACKP. If
5507 WILD_MATCH_P is nonzero, perform the naming matching in "wild" mode (see
5508 function "wild_match" for more information). Return whether we found such
5509 symbols. */
5510
5511static int
5512ada_add_block_renamings (struct obstack *obstackp,
5513 const struct block *block,
5514 const char *name,
5515 domain_enum domain,
5516 int wild_match_p)
5517{
5518 struct using_direct *renaming;
5519 int defns_mark = num_defns_collected (obstackp);
5520
5521 for (renaming = block_using (block);
5522 renaming != NULL;
5523 renaming = renaming->next)
5524 {
5525 const char *r_name;
5526 int name_match;
5527
5528 /* Avoid infinite recursions: skip this renaming if we are actually
5529 already traversing it.
5530
5531 Currently, symbol lookup in Ada don't use the namespace machinery from
5532 C++/Fortran support: skip namespace imports that use them. */
5533 if (renaming->searched
5534 || (renaming->import_src != NULL
5535 && renaming->import_src[0] != '\0')
5536 || (renaming->import_dest != NULL
5537 && renaming->import_dest[0] != '\0'))
5538 continue;
5539 renaming->searched = 1;
5540
5541 /* TODO: here, we perform another name-based symbol lookup, which can
5542 pull its own multiple overloads. In theory, we should be able to do
5543 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5544 not a simple name. But in order to do this, we would need to enhance
5545 the DWARF reader to associate a symbol to this renaming, instead of a
5546 name. So, for now, we do something simpler: re-use the C++/Fortran
5547 namespace machinery. */
5548 r_name = (renaming->alias != NULL
5549 ? renaming->alias
5550 : renaming->declaration);
5551 name_match
5552 = wild_match_p ? wild_match (r_name, name) : strcmp (r_name, name);
5553 if (name_match == 0)
5554 ada_add_all_symbols (obstackp, block, renaming->declaration, domain,
5555 1, NULL);
5556 renaming->searched = 0;
5557 }
5558 return num_defns_collected (obstackp) != defns_mark;
5559}
5560
db230ce3
JB
5561/* Implements compare_names, but only applying the comparision using
5562 the given CASING. */
5b4ee69b 5563
40658b94 5564static int
db230ce3
JB
5565compare_names_with_case (const char *string1, const char *string2,
5566 enum case_sensitivity casing)
40658b94
PH
5567{
5568 while (*string1 != '\0' && *string2 != '\0')
5569 {
db230ce3
JB
5570 char c1, c2;
5571
40658b94
PH
5572 if (isspace (*string1) || isspace (*string2))
5573 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5574
5575 if (casing == case_sensitive_off)
5576 {
5577 c1 = tolower (*string1);
5578 c2 = tolower (*string2);
5579 }
5580 else
5581 {
5582 c1 = *string1;
5583 c2 = *string2;
5584 }
5585 if (c1 != c2)
40658b94 5586 break;
db230ce3 5587
40658b94
PH
5588 string1 += 1;
5589 string2 += 1;
5590 }
db230ce3 5591
40658b94
PH
5592 switch (*string1)
5593 {
5594 case '(':
5595 return strcmp_iw_ordered (string1, string2);
5596 case '_':
5597 if (*string2 == '\0')
5598 {
052874e8 5599 if (is_name_suffix (string1))
40658b94
PH
5600 return 0;
5601 else
1a1d5513 5602 return 1;
40658b94 5603 }
dbb8534f 5604 /* FALLTHROUGH */
40658b94
PH
5605 default:
5606 if (*string2 == '(')
5607 return strcmp_iw_ordered (string1, string2);
5608 else
db230ce3
JB
5609 {
5610 if (casing == case_sensitive_off)
5611 return tolower (*string1) - tolower (*string2);
5612 else
5613 return *string1 - *string2;
5614 }
40658b94 5615 }
ccefe4c4
TT
5616}
5617
db230ce3
JB
5618/* Compare STRING1 to STRING2, with results as for strcmp.
5619 Compatible with strcmp_iw_ordered in that...
5620
5621 strcmp_iw_ordered (STRING1, STRING2) <= 0
5622
5623 ... implies...
5624
5625 compare_names (STRING1, STRING2) <= 0
5626
5627 (they may differ as to what symbols compare equal). */
5628
5629static int
5630compare_names (const char *string1, const char *string2)
5631{
5632 int result;
5633
5634 /* Similar to what strcmp_iw_ordered does, we need to perform
5635 a case-insensitive comparison first, and only resort to
5636 a second, case-sensitive, comparison if the first one was
5637 not sufficient to differentiate the two strings. */
5638
5639 result = compare_names_with_case (string1, string2, case_sensitive_off);
5640 if (result == 0)
5641 result = compare_names_with_case (string1, string2, case_sensitive_on);
5642
5643 return result;
5644}
5645
339c13b6
JB
5646/* Add to OBSTACKP all non-local symbols whose name and domain match
5647 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5648 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5649
5650static void
40658b94
PH
5651add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5652 domain_enum domain, int global,
5653 int is_wild_match)
339c13b6
JB
5654{
5655 struct objfile *objfile;
22cee43f 5656 struct compunit_symtab *cu;
40658b94 5657 struct match_data data;
339c13b6 5658
6475f2fe 5659 memset (&data, 0, sizeof data);
ccefe4c4 5660 data.obstackp = obstackp;
339c13b6 5661
ccefe4c4 5662 ALL_OBJFILES (objfile)
40658b94
PH
5663 {
5664 data.objfile = objfile;
5665
5666 if (is_wild_match)
4186eb54
KS
5667 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5668 aux_add_nonlocal_symbols, &data,
5669 wild_match, NULL);
40658b94 5670 else
4186eb54
KS
5671 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5672 aux_add_nonlocal_symbols, &data,
5673 full_match, compare_names);
22cee43f
PMR
5674
5675 ALL_OBJFILE_COMPUNITS (objfile, cu)
5676 {
5677 const struct block *global_block
5678 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5679
5680 if (ada_add_block_renamings (obstackp, global_block , name, domain,
5681 is_wild_match))
5682 data.found_sym = 1;
5683 }
40658b94
PH
5684 }
5685
5686 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5687 {
5688 ALL_OBJFILES (objfile)
5689 {
224c3ddb 5690 char *name1 = (char *) alloca (strlen (name) + sizeof ("_ada_"));
40658b94
PH
5691 strcpy (name1, "_ada_");
5692 strcpy (name1 + sizeof ("_ada_") - 1, name);
5693 data.objfile = objfile;
ade7ed9e
DE
5694 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5695 global,
0963b4bd
MS
5696 aux_add_nonlocal_symbols,
5697 &data,
40658b94
PH
5698 full_match, compare_names);
5699 }
5700 }
339c13b6
JB
5701}
5702
22cee43f 5703/* Find symbols in DOMAIN matching NAME, in BLOCK and, if FULL_SEARCH is
4eeaa230 5704 non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5705 matches. Add these to OBSTACKP.
4eeaa230 5706
22cee43f
PMR
5707 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5708 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5709 is the one match returned (no other matches in that or
d9680e73 5710 enclosing blocks is returned). If there are any matches in or
22cee43f 5711 surrounding BLOCK, then these alone are returned.
4eeaa230 5712
9f88c959 5713 Names prefixed with "standard__" are handled specially: "standard__"
22cee43f 5714 is first stripped off, and only static and global symbols are searched.
14f9c5c9 5715
22cee43f
PMR
5716 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5717 to lookup global symbols. */
5718
5719static void
5720ada_add_all_symbols (struct obstack *obstackp,
5721 const struct block *block,
5722 const char *name,
5723 domain_enum domain,
5724 int full_search,
5725 int *made_global_lookup_p)
14f9c5c9
AS
5726{
5727 struct symbol *sym;
22cee43f 5728 const int wild_match_p = should_use_wild_match (name);
14f9c5c9 5729
22cee43f
PMR
5730 if (made_global_lookup_p)
5731 *made_global_lookup_p = 0;
339c13b6
JB
5732
5733 /* Special case: If the user specifies a symbol name inside package
5734 Standard, do a non-wild matching of the symbol name without
5735 the "standard__" prefix. This was primarily introduced in order
5736 to allow the user to specifically access the standard exceptions
5737 using, for instance, Standard.Constraint_Error when Constraint_Error
5738 is ambiguous (due to the user defining its own Constraint_Error
5739 entity inside its program). */
22cee43f 5740 if (startswith (name, "standard__"))
4c4b4cd2 5741 {
4c4b4cd2 5742 block = NULL;
22cee43f 5743 name = name + sizeof ("standard__") - 1;
4c4b4cd2
PH
5744 }
5745
339c13b6 5746 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5747
4eeaa230
DE
5748 if (block != NULL)
5749 {
5750 if (full_search)
22cee43f 5751 ada_add_local_symbols (obstackp, name, block, domain, wild_match_p);
4eeaa230
DE
5752 else
5753 {
5754 /* In the !full_search case we're are being called by
5755 ada_iterate_over_symbols, and we don't want to search
5756 superblocks. */
22cee43f
PMR
5757 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5758 wild_match_p);
4eeaa230 5759 }
22cee43f
PMR
5760 if (num_defns_collected (obstackp) > 0 || !full_search)
5761 return;
4eeaa230 5762 }
d2e4a39e 5763
339c13b6
JB
5764 /* No non-global symbols found. Check our cache to see if we have
5765 already performed this search before. If we have, then return
5766 the same result. */
5767
22cee43f 5768 if (lookup_cached_symbol (name, domain, &sym, &block))
4c4b4cd2
PH
5769 {
5770 if (sym != NULL)
22cee43f
PMR
5771 add_defn_to_vec (obstackp, sym, block);
5772 return;
4c4b4cd2 5773 }
14f9c5c9 5774
22cee43f
PMR
5775 if (made_global_lookup_p)
5776 *made_global_lookup_p = 1;
b1eedac9 5777
339c13b6
JB
5778 /* Search symbols from all global blocks. */
5779
22cee43f 5780 add_nonlocal_symbols (obstackp, name, domain, 1, wild_match_p);
d2e4a39e 5781
4c4b4cd2 5782 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5783 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5784
22cee43f
PMR
5785 if (num_defns_collected (obstackp) == 0)
5786 add_nonlocal_symbols (obstackp, name, domain, 0, wild_match_p);
5787}
5788
5789/* Find symbols in DOMAIN matching NAME, in BLOCK and, if full_search is
5790 non-zero, enclosing scope and in global scopes, returning the number of
5791 matches.
5792 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5793 indicating the symbols found and the blocks and symbol tables (if
5794 any) in which they were found. This vector is transient---good only to
5795 the next call of ada_lookup_symbol_list.
5796
5797 When full_search is non-zero, any non-function/non-enumeral
5798 symbol match within the nest of blocks whose innermost member is BLOCK,
5799 is the one match returned (no other matches in that or
5800 enclosing blocks is returned). If there are any matches in or
5801 surrounding BLOCK, then these alone are returned.
5802
5803 Names prefixed with "standard__" are handled specially: "standard__"
5804 is first stripped off, and only static and global symbols are searched. */
5805
5806static int
5807ada_lookup_symbol_list_worker (const char *name, const struct block *block,
5808 domain_enum domain,
5809 struct block_symbol **results,
5810 int full_search)
5811{
5812 const int wild_match_p = should_use_wild_match (name);
5813 int syms_from_global_search;
5814 int ndefns;
5815
5816 obstack_free (&symbol_list_obstack, NULL);
5817 obstack_init (&symbol_list_obstack);
5818 ada_add_all_symbols (&symbol_list_obstack, block, name, domain,
5819 full_search, &syms_from_global_search);
14f9c5c9 5820
4c4b4cd2
PH
5821 ndefns = num_defns_collected (&symbol_list_obstack);
5822 *results = defns_collected (&symbol_list_obstack, 1);
5823
5824 ndefns = remove_extra_symbols (*results, ndefns);
5825
b1eedac9 5826 if (ndefns == 0 && full_search && syms_from_global_search)
22cee43f 5827 cache_symbol (name, domain, NULL, NULL);
14f9c5c9 5828
b1eedac9 5829 if (ndefns == 1 && full_search && syms_from_global_search)
22cee43f 5830 cache_symbol (name, domain, (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5831
22cee43f 5832 ndefns = remove_irrelevant_renamings (*results, ndefns, block);
14f9c5c9
AS
5833 return ndefns;
5834}
5835
4eeaa230
DE
5836/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5837 in global scopes, returning the number of matches, and setting *RESULTS
5838 to a vector of (SYM,BLOCK) tuples.
5839 See ada_lookup_symbol_list_worker for further details. */
5840
5841int
5842ada_lookup_symbol_list (const char *name0, const struct block *block0,
d12307c1 5843 domain_enum domain, struct block_symbol **results)
4eeaa230
DE
5844{
5845 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5846}
5847
5848/* Implementation of the la_iterate_over_symbols method. */
5849
5850static void
14bc53a8
PA
5851ada_iterate_over_symbols
5852 (const struct block *block, const char *name, domain_enum domain,
5853 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5854{
5855 int ndefs, i;
d12307c1 5856 struct block_symbol *results;
4eeaa230
DE
5857
5858 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5859 for (i = 0; i < ndefs; ++i)
5860 {
14bc53a8 5861 if (!callback (results[i].symbol))
4eeaa230
DE
5862 break;
5863 }
5864}
5865
f8eba3c6 5866/* If NAME is the name of an entity, return a string that should
2f408ecb 5867 be used to look that entity up in Ada units.
f8eba3c6
TT
5868
5869 NAME can have any form that the "break" or "print" commands might
5870 recognize. In other words, it does not have to be the "natural"
5871 name, or the "encoded" name. */
5872
2f408ecb 5873std::string
f8eba3c6
TT
5874ada_name_for_lookup (const char *name)
5875{
f8eba3c6
TT
5876 int nlen = strlen (name);
5877
5878 if (name[0] == '<' && name[nlen - 1] == '>')
2f408ecb 5879 return std::string (name + 1, nlen - 2);
f8eba3c6 5880 else
2f408ecb 5881 return ada_encode (ada_fold_name (name));
f8eba3c6
TT
5882}
5883
4e5c77fe
JB
5884/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5885 to 1, but choosing the first symbol found if there are multiple
5886 choices.
5887
5e2336be
JB
5888 The result is stored in *INFO, which must be non-NULL.
5889 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5890
5891void
5892ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5893 domain_enum domain,
d12307c1 5894 struct block_symbol *info)
14f9c5c9 5895{
d12307c1 5896 struct block_symbol *candidates;
14f9c5c9
AS
5897 int n_candidates;
5898
5e2336be 5899 gdb_assert (info != NULL);
d12307c1 5900 memset (info, 0, sizeof (struct block_symbol));
4e5c77fe 5901
fe978cb0 5902 n_candidates = ada_lookup_symbol_list (name, block, domain, &candidates);
14f9c5c9 5903 if (n_candidates == 0)
4e5c77fe 5904 return;
4c4b4cd2 5905
5e2336be 5906 *info = candidates[0];
d12307c1 5907 info->symbol = fixup_symbol_section (info->symbol, NULL);
4e5c77fe 5908}
aeb5907d
JB
5909
5910/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5911 scope and in global scopes, or NULL if none. NAME is folded and
5912 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5913 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5914 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5915
d12307c1 5916struct block_symbol
aeb5907d 5917ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5918 domain_enum domain, int *is_a_field_of_this)
aeb5907d 5919{
d12307c1 5920 struct block_symbol info;
4e5c77fe 5921
aeb5907d
JB
5922 if (is_a_field_of_this != NULL)
5923 *is_a_field_of_this = 0;
5924
4e5c77fe 5925 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
fe978cb0 5926 block0, domain, &info);
d12307c1 5927 return info;
4c4b4cd2 5928}
14f9c5c9 5929
d12307c1 5930static struct block_symbol
f606139a
DE
5931ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5932 const char *name,
76a01679 5933 const struct block *block,
21b556f4 5934 const domain_enum domain)
4c4b4cd2 5935{
d12307c1 5936 struct block_symbol sym;
04dccad0
JB
5937
5938 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5939 if (sym.symbol != NULL)
04dccad0
JB
5940 return sym;
5941
5942 /* If we haven't found a match at this point, try the primitive
5943 types. In other languages, this search is performed before
5944 searching for global symbols in order to short-circuit that
5945 global-symbol search if it happens that the name corresponds
5946 to a primitive type. But we cannot do the same in Ada, because
5947 it is perfectly legitimate for a program to declare a type which
5948 has the same name as a standard type. If looking up a type in
5949 that situation, we have traditionally ignored the primitive type
5950 in favor of user-defined types. This is why, unlike most other
5951 languages, we search the primitive types this late and only after
5952 having searched the global symbols without success. */
5953
5954 if (domain == VAR_DOMAIN)
5955 {
5956 struct gdbarch *gdbarch;
5957
5958 if (block == NULL)
5959 gdbarch = target_gdbarch ();
5960 else
5961 gdbarch = block_gdbarch (block);
d12307c1
PMR
5962 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5963 if (sym.symbol != NULL)
04dccad0
JB
5964 return sym;
5965 }
5966
d12307c1 5967 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5968}
5969
5970
4c4b4cd2
PH
5971/* True iff STR is a possible encoded suffix of a normal Ada name
5972 that is to be ignored for matching purposes. Suffixes of parallel
5973 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5974 are given by any of the regular expressions:
4c4b4cd2 5975
babe1480
JB
5976 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5977 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5978 TKB [subprogram suffix for task bodies]
babe1480 5979 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5980 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5981
5982 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5983 match is performed. This sequence is used to differentiate homonyms,
5984 is an optional part of a valid name suffix. */
4c4b4cd2 5985
14f9c5c9 5986static int
d2e4a39e 5987is_name_suffix (const char *str)
14f9c5c9
AS
5988{
5989 int k;
4c4b4cd2
PH
5990 const char *matching;
5991 const int len = strlen (str);
5992
babe1480
JB
5993 /* Skip optional leading __[0-9]+. */
5994
4c4b4cd2
PH
5995 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5996 {
babe1480
JB
5997 str += 3;
5998 while (isdigit (str[0]))
5999 str += 1;
4c4b4cd2 6000 }
babe1480
JB
6001
6002 /* [.$][0-9]+ */
4c4b4cd2 6003
babe1480 6004 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 6005 {
babe1480 6006 matching = str + 1;
4c4b4cd2
PH
6007 while (isdigit (matching[0]))
6008 matching += 1;
6009 if (matching[0] == '\0')
6010 return 1;
6011 }
6012
6013 /* ___[0-9]+ */
babe1480 6014
4c4b4cd2
PH
6015 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6016 {
6017 matching = str + 3;
6018 while (isdigit (matching[0]))
6019 matching += 1;
6020 if (matching[0] == '\0')
6021 return 1;
6022 }
6023
9ac7f98e
JB
6024 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6025
6026 if (strcmp (str, "TKB") == 0)
6027 return 1;
6028
529cad9c
PH
6029#if 0
6030 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
6031 with a N at the end. Unfortunately, the compiler uses the same
6032 convention for other internal types it creates. So treating
529cad9c 6033 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
6034 some regressions. For instance, consider the case of an enumerated
6035 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
6036 name ends with N.
6037 Having a single character like this as a suffix carrying some
0963b4bd 6038 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
6039 to be something like "_N" instead. In the meantime, do not do
6040 the following check. */
6041 /* Protected Object Subprograms */
6042 if (len == 1 && str [0] == 'N')
6043 return 1;
6044#endif
6045
6046 /* _E[0-9]+[bs]$ */
6047 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6048 {
6049 matching = str + 3;
6050 while (isdigit (matching[0]))
6051 matching += 1;
6052 if ((matching[0] == 'b' || matching[0] == 's')
6053 && matching [1] == '\0')
6054 return 1;
6055 }
6056
4c4b4cd2
PH
6057 /* ??? We should not modify STR directly, as we are doing below. This
6058 is fine in this case, but may become problematic later if we find
6059 that this alternative did not work, and want to try matching
6060 another one from the begining of STR. Since we modified it, we
6061 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6062 if (str[0] == 'X')
6063 {
6064 str += 1;
d2e4a39e 6065 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6066 {
6067 if (str[0] != 'n' && str[0] != 'b')
6068 return 0;
6069 str += 1;
6070 }
14f9c5c9 6071 }
babe1480 6072
14f9c5c9
AS
6073 if (str[0] == '\000')
6074 return 1;
babe1480 6075
d2e4a39e 6076 if (str[0] == '_')
14f9c5c9
AS
6077 {
6078 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6079 return 0;
d2e4a39e 6080 if (str[2] == '_')
4c4b4cd2 6081 {
61ee279c
PH
6082 if (strcmp (str + 3, "JM") == 0)
6083 return 1;
6084 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6085 the LJM suffix in favor of the JM one. But we will
6086 still accept LJM as a valid suffix for a reasonable
6087 amount of time, just to allow ourselves to debug programs
6088 compiled using an older version of GNAT. */
4c4b4cd2
PH
6089 if (strcmp (str + 3, "LJM") == 0)
6090 return 1;
6091 if (str[3] != 'X')
6092 return 0;
1265e4aa
JB
6093 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6094 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6095 return 1;
6096 if (str[4] == 'R' && str[5] != 'T')
6097 return 1;
6098 return 0;
6099 }
6100 if (!isdigit (str[2]))
6101 return 0;
6102 for (k = 3; str[k] != '\0'; k += 1)
6103 if (!isdigit (str[k]) && str[k] != '_')
6104 return 0;
14f9c5c9
AS
6105 return 1;
6106 }
4c4b4cd2 6107 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6108 {
4c4b4cd2
PH
6109 for (k = 2; str[k] != '\0'; k += 1)
6110 if (!isdigit (str[k]) && str[k] != '_')
6111 return 0;
14f9c5c9
AS
6112 return 1;
6113 }
6114 return 0;
6115}
d2e4a39e 6116
aeb5907d
JB
6117/* Return non-zero if the string starting at NAME and ending before
6118 NAME_END contains no capital letters. */
529cad9c
PH
6119
6120static int
6121is_valid_name_for_wild_match (const char *name0)
6122{
6123 const char *decoded_name = ada_decode (name0);
6124 int i;
6125
5823c3ef
JB
6126 /* If the decoded name starts with an angle bracket, it means that
6127 NAME0 does not follow the GNAT encoding format. It should then
6128 not be allowed as a possible wild match. */
6129 if (decoded_name[0] == '<')
6130 return 0;
6131
529cad9c
PH
6132 for (i=0; decoded_name[i] != '\0'; i++)
6133 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6134 return 0;
6135
6136 return 1;
6137}
6138
73589123
PH
6139/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6140 that could start a simple name. Assumes that *NAMEP points into
6141 the string beginning at NAME0. */
4c4b4cd2 6142
14f9c5c9 6143static int
73589123 6144advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6145{
73589123 6146 const char *name = *namep;
5b4ee69b 6147
5823c3ef 6148 while (1)
14f9c5c9 6149 {
aa27d0b3 6150 int t0, t1;
73589123
PH
6151
6152 t0 = *name;
6153 if (t0 == '_')
6154 {
6155 t1 = name[1];
6156 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6157 {
6158 name += 1;
61012eef 6159 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6160 break;
6161 else
6162 name += 1;
6163 }
aa27d0b3
JB
6164 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6165 || name[2] == target0))
73589123
PH
6166 {
6167 name += 2;
6168 break;
6169 }
6170 else
6171 return 0;
6172 }
6173 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6174 name += 1;
6175 else
5823c3ef 6176 return 0;
73589123
PH
6177 }
6178
6179 *namep = name;
6180 return 1;
6181}
6182
6183/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
6184 informational suffixes of NAME (i.e., for which is_name_suffix is
6185 true). Assumes that PATN is a lower-cased Ada simple name. */
6186
6187static int
6188wild_match (const char *name, const char *patn)
6189{
22e048c9 6190 const char *p;
73589123
PH
6191 const char *name0 = name;
6192
6193 while (1)
6194 {
6195 const char *match = name;
6196
6197 if (*name == *patn)
6198 {
6199 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6200 if (*p != *name)
6201 break;
6202 if (*p == '\0' && is_name_suffix (name))
6203 return match != name0 && !is_valid_name_for_wild_match (name0);
6204
6205 if (name[-1] == '_')
6206 name -= 1;
6207 }
6208 if (!advance_wild_match (&name, name0, *patn))
6209 return 1;
96d887e8 6210 }
96d887e8
PH
6211}
6212
40658b94
PH
6213/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
6214 informational suffix. */
6215
c4d840bd
PH
6216static int
6217full_match (const char *sym_name, const char *search_name)
6218{
40658b94 6219 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
6220}
6221
6222
96d887e8
PH
6223/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
6224 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 6225 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 6226 OBJFILE is the section containing BLOCK. */
96d887e8
PH
6227
6228static void
6229ada_add_block_symbols (struct obstack *obstackp,
f0c5f9b2 6230 const struct block *block, const char *name,
96d887e8 6231 domain_enum domain, struct objfile *objfile,
2570f2b7 6232 int wild)
96d887e8 6233{
8157b174 6234 struct block_iterator iter;
96d887e8
PH
6235 int name_len = strlen (name);
6236 /* A matching argument symbol, if any. */
6237 struct symbol *arg_sym;
6238 /* Set true when we find a matching non-argument symbol. */
6239 int found_sym;
6240 struct symbol *sym;
6241
6242 arg_sym = NULL;
6243 found_sym = 0;
6244 if (wild)
6245 {
8157b174
TT
6246 for (sym = block_iter_match_first (block, name, wild_match, &iter);
6247 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 6248 {
4186eb54
KS
6249 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6250 SYMBOL_DOMAIN (sym), domain)
73589123 6251 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 6252 {
2a2d4dc3
AS
6253 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
6254 continue;
6255 else if (SYMBOL_IS_ARGUMENT (sym))
6256 arg_sym = sym;
6257 else
6258 {
76a01679
JB
6259 found_sym = 1;
6260 add_defn_to_vec (obstackp,
6261 fixup_symbol_section (sym, objfile),
2570f2b7 6262 block);
76a01679
JB
6263 }
6264 }
6265 }
96d887e8
PH
6266 }
6267 else
6268 {
8157b174
TT
6269 for (sym = block_iter_match_first (block, name, full_match, &iter);
6270 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 6271 {
4186eb54
KS
6272 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6273 SYMBOL_DOMAIN (sym), domain))
76a01679 6274 {
c4d840bd
PH
6275 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6276 {
6277 if (SYMBOL_IS_ARGUMENT (sym))
6278 arg_sym = sym;
6279 else
2a2d4dc3 6280 {
c4d840bd
PH
6281 found_sym = 1;
6282 add_defn_to_vec (obstackp,
6283 fixup_symbol_section (sym, objfile),
6284 block);
2a2d4dc3 6285 }
c4d840bd 6286 }
76a01679
JB
6287 }
6288 }
96d887e8
PH
6289 }
6290
22cee43f
PMR
6291 /* Handle renamings. */
6292
6293 if (ada_add_block_renamings (obstackp, block, name, domain, wild))
6294 found_sym = 1;
6295
96d887e8
PH
6296 if (!found_sym && arg_sym != NULL)
6297 {
76a01679
JB
6298 add_defn_to_vec (obstackp,
6299 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6300 block);
96d887e8
PH
6301 }
6302
6303 if (!wild)
6304 {
6305 arg_sym = NULL;
6306 found_sym = 0;
6307
6308 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6309 {
4186eb54
KS
6310 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6311 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6312 {
6313 int cmp;
6314
6315 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6316 if (cmp == 0)
6317 {
61012eef 6318 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6319 if (cmp == 0)
6320 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6321 name_len);
6322 }
6323
6324 if (cmp == 0
6325 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6326 {
2a2d4dc3
AS
6327 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6328 {
6329 if (SYMBOL_IS_ARGUMENT (sym))
6330 arg_sym = sym;
6331 else
6332 {
6333 found_sym = 1;
6334 add_defn_to_vec (obstackp,
6335 fixup_symbol_section (sym, objfile),
6336 block);
6337 }
6338 }
76a01679
JB
6339 }
6340 }
76a01679 6341 }
96d887e8
PH
6342
6343 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6344 They aren't parameters, right? */
6345 if (!found_sym && arg_sym != NULL)
6346 {
6347 add_defn_to_vec (obstackp,
76a01679 6348 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6349 block);
96d887e8
PH
6350 }
6351 }
6352}
6353\f
41d27058
JB
6354
6355 /* Symbol Completion */
6356
6357/* If SYM_NAME is a completion candidate for TEXT, return this symbol
6358 name in a form that's appropriate for the completion. The result
6359 does not need to be deallocated, but is only good until the next call.
6360
6361 TEXT_LEN is equal to the length of TEXT.
e701b3c0 6362 Perform a wild match if WILD_MATCH_P is set.
6ea35997 6363 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
6364 in its encoded form. */
6365
6366static const char *
6367symbol_completion_match (const char *sym_name,
6368 const char *text, int text_len,
6ea35997 6369 int wild_match_p, int encoded_p)
41d27058 6370{
41d27058
JB
6371 const int verbatim_match = (text[0] == '<');
6372 int match = 0;
6373
6374 if (verbatim_match)
6375 {
6376 /* Strip the leading angle bracket. */
6377 text = text + 1;
6378 text_len--;
6379 }
6380
6381 /* First, test against the fully qualified name of the symbol. */
6382
6383 if (strncmp (sym_name, text, text_len) == 0)
6384 match = 1;
6385
6ea35997 6386 if (match && !encoded_p)
41d27058
JB
6387 {
6388 /* One needed check before declaring a positive match is to verify
6389 that iff we are doing a verbatim match, the decoded version
6390 of the symbol name starts with '<'. Otherwise, this symbol name
6391 is not a suitable completion. */
6392 const char *sym_name_copy = sym_name;
6393 int has_angle_bracket;
6394
6395 sym_name = ada_decode (sym_name);
6396 has_angle_bracket = (sym_name[0] == '<');
6397 match = (has_angle_bracket == verbatim_match);
6398 sym_name = sym_name_copy;
6399 }
6400
6401 if (match && !verbatim_match)
6402 {
6403 /* When doing non-verbatim match, another check that needs to
6404 be done is to verify that the potentially matching symbol name
6405 does not include capital letters, because the ada-mode would
6406 not be able to understand these symbol names without the
6407 angle bracket notation. */
6408 const char *tmp;
6409
6410 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6411 if (*tmp != '\0')
6412 match = 0;
6413 }
6414
6415 /* Second: Try wild matching... */
6416
e701b3c0 6417 if (!match && wild_match_p)
41d27058
JB
6418 {
6419 /* Since we are doing wild matching, this means that TEXT
6420 may represent an unqualified symbol name. We therefore must
6421 also compare TEXT against the unqualified name of the symbol. */
6422 sym_name = ada_unqualified_name (ada_decode (sym_name));
6423
6424 if (strncmp (sym_name, text, text_len) == 0)
6425 match = 1;
6426 }
6427
6428 /* Finally: If we found a mach, prepare the result to return. */
6429
6430 if (!match)
6431 return NULL;
6432
6433 if (verbatim_match)
6434 sym_name = add_angle_brackets (sym_name);
6435
6ea35997 6436 if (!encoded_p)
41d27058
JB
6437 sym_name = ada_decode (sym_name);
6438
6439 return sym_name;
6440}
6441
eb3ff9a5 6442/* A companion function to ada_collect_symbol_completion_matches().
41d27058 6443 Check if SYM_NAME represents a symbol which name would be suitable
eb3ff9a5
PA
6444 to complete TEXT (TEXT_LEN is the length of TEXT), in which case it
6445 is added as a completion match to TRACKER.
41d27058
JB
6446
6447 ORIG_TEXT is the string original string from the user command
6448 that needs to be completed. WORD is the entire command on which
6449 completion should be performed. These two parameters are used to
6450 determine which part of the symbol name should be added to the
6451 completion vector.
c0af1706 6452 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 6453 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
6454 encoded formed (in which case the completion should also be
6455 encoded). */
6456
6457static void
eb3ff9a5
PA
6458symbol_completion_add (completion_tracker &tracker,
6459 const char *sym_name,
41d27058
JB
6460 const char *text, int text_len,
6461 const char *orig_text, const char *word,
cb8e9b97 6462 int wild_match_p, int encoded_p)
41d27058
JB
6463{
6464 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 6465 wild_match_p, encoded_p);
41d27058
JB
6466 char *completion;
6467
6468 if (match == NULL)
6469 return;
6470
6471 /* We found a match, so add the appropriate completion to the given
6472 string vector. */
6473
6474 if (word == orig_text)
6475 {
224c3ddb 6476 completion = (char *) xmalloc (strlen (match) + 5);
41d27058
JB
6477 strcpy (completion, match);
6478 }
6479 else if (word > orig_text)
6480 {
6481 /* Return some portion of sym_name. */
224c3ddb 6482 completion = (char *) xmalloc (strlen (match) + 5);
41d27058
JB
6483 strcpy (completion, match + (word - orig_text));
6484 }
6485 else
6486 {
6487 /* Return some of ORIG_TEXT plus sym_name. */
224c3ddb 6488 completion = (char *) xmalloc (strlen (match) + (orig_text - word) + 5);
41d27058
JB
6489 strncpy (completion, word, orig_text - word);
6490 completion[orig_text - word] = '\0';
6491 strcat (completion, match);
6492 }
6493
eb3ff9a5 6494 tracker.add_completion (gdb::unique_xmalloc_ptr<char> (completion));
41d27058
JB
6495}
6496
eb3ff9a5
PA
6497/* Add the list of possible symbol names completing TEXT0 to TRACKER.
6498 WORD is the entire command on which completion is made. */
41d27058 6499
eb3ff9a5
PA
6500static void
6501ada_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 6502 complete_symbol_mode mode,
eb3ff9a5
PA
6503 const char *text0, const char *word,
6504 enum type_code code)
41d27058
JB
6505{
6506 char *text;
6507 int text_len;
b1ed564a
JB
6508 int wild_match_p;
6509 int encoded_p;
41d27058 6510 struct symbol *sym;
43f3e411 6511 struct compunit_symtab *s;
41d27058
JB
6512 struct minimal_symbol *msymbol;
6513 struct objfile *objfile;
3977b71f 6514 const struct block *b, *surrounding_static_block = 0;
41d27058 6515 int i;
8157b174 6516 struct block_iterator iter;
b8fea896 6517 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6518
2f68a895
TT
6519 gdb_assert (code == TYPE_CODE_UNDEF);
6520
41d27058
JB
6521 if (text0[0] == '<')
6522 {
6523 text = xstrdup (text0);
6524 make_cleanup (xfree, text);
6525 text_len = strlen (text);
b1ed564a
JB
6526 wild_match_p = 0;
6527 encoded_p = 1;
41d27058
JB
6528 }
6529 else
6530 {
6531 text = xstrdup (ada_encode (text0));
6532 make_cleanup (xfree, text);
6533 text_len = strlen (text);
6534 for (i = 0; i < text_len; i++)
6535 text[i] = tolower (text[i]);
6536
b1ed564a 6537 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
6538 /* If the name contains a ".", then the user is entering a fully
6539 qualified entity name, and the match must not be done in wild
6540 mode. Similarly, if the user wants to complete what looks like
6541 an encoded name, the match must not be done in wild mode. */
b1ed564a 6542 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
6543 }
6544
6545 /* First, look at the partial symtab symbols. */
14bc53a8
PA
6546 expand_symtabs_matching (NULL,
6547 [&] (const char *symname)
6548 {
6549 return symbol_completion_match (symname,
6550 text, text_len,
6551 wild_match_p,
6552 encoded_p);
6553 },
6554 NULL,
6555 ALL_DOMAIN);
41d27058
JB
6556
6557 /* At this point scan through the misc symbol vectors and add each
6558 symbol you find to the list. Eventually we want to ignore
6559 anything that isn't a text symbol (everything else will be
6560 handled by the psymtab code above). */
6561
6562 ALL_MSYMBOLS (objfile, msymbol)
6563 {
6564 QUIT;
eb3ff9a5 6565 symbol_completion_add (tracker, MSYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
6566 text, text_len, text0, word, wild_match_p,
6567 encoded_p);
41d27058
JB
6568 }
6569
6570 /* Search upwards from currently selected frame (so that we can
6571 complete on local vars. */
6572
6573 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6574 {
6575 if (!BLOCK_SUPERBLOCK (b))
6576 surrounding_static_block = b; /* For elmin of dups */
6577
6578 ALL_BLOCK_SYMBOLS (b, iter, sym)
6579 {
eb3ff9a5 6580 symbol_completion_add (tracker, SYMBOL_LINKAGE_NAME (sym),
41d27058 6581 text, text_len, text0, word,
b1ed564a 6582 wild_match_p, encoded_p);
41d27058
JB
6583 }
6584 }
6585
6586 /* Go through the symtabs and check the externs and statics for
43f3e411 6587 symbols which match. */
41d27058 6588
43f3e411 6589 ALL_COMPUNITS (objfile, s)
41d27058
JB
6590 {
6591 QUIT;
43f3e411 6592 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6593 ALL_BLOCK_SYMBOLS (b, iter, sym)
6594 {
eb3ff9a5 6595 symbol_completion_add (tracker, SYMBOL_LINKAGE_NAME (sym),
41d27058 6596 text, text_len, text0, word,
b1ed564a 6597 wild_match_p, encoded_p);
41d27058
JB
6598 }
6599 }
6600
43f3e411 6601 ALL_COMPUNITS (objfile, s)
41d27058
JB
6602 {
6603 QUIT;
43f3e411 6604 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6605 /* Don't do this block twice. */
6606 if (b == surrounding_static_block)
6607 continue;
6608 ALL_BLOCK_SYMBOLS (b, iter, sym)
6609 {
eb3ff9a5 6610 symbol_completion_add (tracker, SYMBOL_LINKAGE_NAME (sym),
41d27058 6611 text, text_len, text0, word,
b1ed564a 6612 wild_match_p, encoded_p);
41d27058
JB
6613 }
6614 }
6615
b8fea896 6616 do_cleanups (old_chain);
41d27058
JB
6617}
6618
963a6417 6619 /* Field Access */
96d887e8 6620
73fb9985
JB
6621/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6622 for tagged types. */
6623
6624static int
6625ada_is_dispatch_table_ptr_type (struct type *type)
6626{
0d5cff50 6627 const char *name;
73fb9985
JB
6628
6629 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6630 return 0;
6631
6632 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6633 if (name == NULL)
6634 return 0;
6635
6636 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6637}
6638
ac4a2da4
JG
6639/* Return non-zero if TYPE is an interface tag. */
6640
6641static int
6642ada_is_interface_tag (struct type *type)
6643{
6644 const char *name = TYPE_NAME (type);
6645
6646 if (name == NULL)
6647 return 0;
6648
6649 return (strcmp (name, "ada__tags__interface_tag") == 0);
6650}
6651
963a6417
PH
6652/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6653 to be invisible to users. */
96d887e8 6654
963a6417
PH
6655int
6656ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6657{
963a6417
PH
6658 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6659 return 1;
ffde82bf 6660
73fb9985
JB
6661 /* Check the name of that field. */
6662 {
6663 const char *name = TYPE_FIELD_NAME (type, field_num);
6664
6665 /* Anonymous field names should not be printed.
6666 brobecker/2007-02-20: I don't think this can actually happen
6667 but we don't want to print the value of annonymous fields anyway. */
6668 if (name == NULL)
6669 return 1;
6670
ffde82bf
JB
6671 /* Normally, fields whose name start with an underscore ("_")
6672 are fields that have been internally generated by the compiler,
6673 and thus should not be printed. The "_parent" field is special,
6674 however: This is a field internally generated by the compiler
6675 for tagged types, and it contains the components inherited from
6676 the parent type. This field should not be printed as is, but
6677 should not be ignored either. */
61012eef 6678 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6679 return 1;
6680 }
6681
ac4a2da4
JG
6682 /* If this is the dispatch table of a tagged type or an interface tag,
6683 then ignore. */
73fb9985 6684 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6685 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6686 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6687 return 1;
6688
6689 /* Not a special field, so it should not be ignored. */
6690 return 0;
963a6417 6691}
96d887e8 6692
963a6417 6693/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6694 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6695
963a6417
PH
6696int
6697ada_is_tagged_type (struct type *type, int refok)
6698{
988f6b3d 6699 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
963a6417 6700}
96d887e8 6701
963a6417 6702/* True iff TYPE represents the type of X'Tag */
96d887e8 6703
963a6417
PH
6704int
6705ada_is_tag_type (struct type *type)
6706{
460efde1
JB
6707 type = ada_check_typedef (type);
6708
963a6417
PH
6709 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6710 return 0;
6711 else
96d887e8 6712 {
963a6417 6713 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6714
963a6417
PH
6715 return (name != NULL
6716 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6717 }
96d887e8
PH
6718}
6719
963a6417 6720/* The type of the tag on VAL. */
76a01679 6721
963a6417
PH
6722struct type *
6723ada_tag_type (struct value *val)
96d887e8 6724{
988f6b3d 6725 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
963a6417 6726}
96d887e8 6727
b50d69b5
JG
6728/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6729 retired at Ada 05). */
6730
6731static int
6732is_ada95_tag (struct value *tag)
6733{
6734 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6735}
6736
963a6417 6737/* The value of the tag on VAL. */
96d887e8 6738
963a6417
PH
6739struct value *
6740ada_value_tag (struct value *val)
6741{
03ee6b2e 6742 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6743}
6744
963a6417
PH
6745/* The value of the tag on the object of type TYPE whose contents are
6746 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6747 ADDRESS. */
96d887e8 6748
963a6417 6749static struct value *
10a2c479 6750value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6751 const gdb_byte *valaddr,
963a6417 6752 CORE_ADDR address)
96d887e8 6753{
b5385fc0 6754 int tag_byte_offset;
963a6417 6755 struct type *tag_type;
5b4ee69b 6756
963a6417 6757 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6758 NULL, NULL, NULL))
96d887e8 6759 {
fc1a4b47 6760 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6761 ? NULL
6762 : valaddr + tag_byte_offset);
963a6417 6763 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6764
963a6417 6765 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6766 }
963a6417
PH
6767 return NULL;
6768}
96d887e8 6769
963a6417
PH
6770static struct type *
6771type_from_tag (struct value *tag)
6772{
6773 const char *type_name = ada_tag_name (tag);
5b4ee69b 6774
963a6417
PH
6775 if (type_name != NULL)
6776 return ada_find_any_type (ada_encode (type_name));
6777 return NULL;
6778}
96d887e8 6779
b50d69b5
JG
6780/* Given a value OBJ of a tagged type, return a value of this
6781 type at the base address of the object. The base address, as
6782 defined in Ada.Tags, it is the address of the primary tag of
6783 the object, and therefore where the field values of its full
6784 view can be fetched. */
6785
6786struct value *
6787ada_tag_value_at_base_address (struct value *obj)
6788{
b50d69b5
JG
6789 struct value *val;
6790 LONGEST offset_to_top = 0;
6791 struct type *ptr_type, *obj_type;
6792 struct value *tag;
6793 CORE_ADDR base_address;
6794
6795 obj_type = value_type (obj);
6796
6797 /* It is the responsability of the caller to deref pointers. */
6798
6799 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6800 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6801 return obj;
6802
6803 tag = ada_value_tag (obj);
6804 if (!tag)
6805 return obj;
6806
6807 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6808
6809 if (is_ada95_tag (tag))
6810 return obj;
6811
6812 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6813 ptr_type = lookup_pointer_type (ptr_type);
6814 val = value_cast (ptr_type, tag);
6815 if (!val)
6816 return obj;
6817
6818 /* It is perfectly possible that an exception be raised while
6819 trying to determine the base address, just like for the tag;
6820 see ada_tag_name for more details. We do not print the error
6821 message for the same reason. */
6822
492d29ea 6823 TRY
b50d69b5
JG
6824 {
6825 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6826 }
6827
492d29ea
PA
6828 CATCH (e, RETURN_MASK_ERROR)
6829 {
6830 return obj;
6831 }
6832 END_CATCH
b50d69b5
JG
6833
6834 /* If offset is null, nothing to do. */
6835
6836 if (offset_to_top == 0)
6837 return obj;
6838
6839 /* -1 is a special case in Ada.Tags; however, what should be done
6840 is not quite clear from the documentation. So do nothing for
6841 now. */
6842
6843 if (offset_to_top == -1)
6844 return obj;
6845
6846 base_address = value_address (obj) - offset_to_top;
6847 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6848
6849 /* Make sure that we have a proper tag at the new address.
6850 Otherwise, offset_to_top is bogus (which can happen when
6851 the object is not initialized yet). */
6852
6853 if (!tag)
6854 return obj;
6855
6856 obj_type = type_from_tag (tag);
6857
6858 if (!obj_type)
6859 return obj;
6860
6861 return value_from_contents_and_address (obj_type, NULL, base_address);
6862}
6863
1b611343
JB
6864/* Return the "ada__tags__type_specific_data" type. */
6865
6866static struct type *
6867ada_get_tsd_type (struct inferior *inf)
963a6417 6868{
1b611343 6869 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6870
1b611343
JB
6871 if (data->tsd_type == 0)
6872 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6873 return data->tsd_type;
6874}
529cad9c 6875
1b611343
JB
6876/* Return the TSD (type-specific data) associated to the given TAG.
6877 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6878
1b611343 6879 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6880
1b611343
JB
6881static struct value *
6882ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6883{
4c4b4cd2 6884 struct value *val;
1b611343 6885 struct type *type;
5b4ee69b 6886
1b611343
JB
6887 /* First option: The TSD is simply stored as a field of our TAG.
6888 Only older versions of GNAT would use this format, but we have
6889 to test it first, because there are no visible markers for
6890 the current approach except the absence of that field. */
529cad9c 6891
1b611343
JB
6892 val = ada_value_struct_elt (tag, "tsd", 1);
6893 if (val)
6894 return val;
e802dbe0 6895
1b611343
JB
6896 /* Try the second representation for the dispatch table (in which
6897 there is no explicit 'tsd' field in the referent of the tag pointer,
6898 and instead the tsd pointer is stored just before the dispatch
6899 table. */
e802dbe0 6900
1b611343
JB
6901 type = ada_get_tsd_type (current_inferior());
6902 if (type == NULL)
6903 return NULL;
6904 type = lookup_pointer_type (lookup_pointer_type (type));
6905 val = value_cast (type, tag);
6906 if (val == NULL)
6907 return NULL;
6908 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6909}
6910
1b611343
JB
6911/* Given the TSD of a tag (type-specific data), return a string
6912 containing the name of the associated type.
6913
6914 The returned value is good until the next call. May return NULL
6915 if we are unable to determine the tag name. */
6916
6917static char *
6918ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6919{
529cad9c
PH
6920 static char name[1024];
6921 char *p;
1b611343 6922 struct value *val;
529cad9c 6923
1b611343 6924 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6925 if (val == NULL)
1b611343 6926 return NULL;
4c4b4cd2
PH
6927 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6928 for (p = name; *p != '\0'; p += 1)
6929 if (isalpha (*p))
6930 *p = tolower (*p);
1b611343 6931 return name;
4c4b4cd2
PH
6932}
6933
6934/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6935 a C string.
6936
6937 Return NULL if the TAG is not an Ada tag, or if we were unable to
6938 determine the name of that tag. The result is good until the next
6939 call. */
4c4b4cd2
PH
6940
6941const char *
6942ada_tag_name (struct value *tag)
6943{
1b611343 6944 char *name = NULL;
5b4ee69b 6945
df407dfe 6946 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6947 return NULL;
1b611343
JB
6948
6949 /* It is perfectly possible that an exception be raised while trying
6950 to determine the TAG's name, even under normal circumstances:
6951 The associated variable may be uninitialized or corrupted, for
6952 instance. We do not let any exception propagate past this point.
6953 instead we return NULL.
6954
6955 We also do not print the error message either (which often is very
6956 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6957 the caller print a more meaningful message if necessary. */
492d29ea 6958 TRY
1b611343
JB
6959 {
6960 struct value *tsd = ada_get_tsd_from_tag (tag);
6961
6962 if (tsd != NULL)
6963 name = ada_tag_name_from_tsd (tsd);
6964 }
492d29ea
PA
6965 CATCH (e, RETURN_MASK_ERROR)
6966 {
6967 }
6968 END_CATCH
1b611343
JB
6969
6970 return name;
4c4b4cd2
PH
6971}
6972
6973/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6974
d2e4a39e 6975struct type *
ebf56fd3 6976ada_parent_type (struct type *type)
14f9c5c9
AS
6977{
6978 int i;
6979
61ee279c 6980 type = ada_check_typedef (type);
14f9c5c9
AS
6981
6982 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6983 return NULL;
6984
6985 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6986 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6987 {
6988 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6989
6990 /* If the _parent field is a pointer, then dereference it. */
6991 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6992 parent_type = TYPE_TARGET_TYPE (parent_type);
6993 /* If there is a parallel XVS type, get the actual base type. */
6994 parent_type = ada_get_base_type (parent_type);
6995
6996 return ada_check_typedef (parent_type);
6997 }
14f9c5c9
AS
6998
6999 return NULL;
7000}
7001
4c4b4cd2
PH
7002/* True iff field number FIELD_NUM of structure type TYPE contains the
7003 parent-type (inherited) fields of a derived type. Assumes TYPE is
7004 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
7005
7006int
ebf56fd3 7007ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 7008{
61ee279c 7009 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 7010
4c4b4cd2 7011 return (name != NULL
61012eef
GB
7012 && (startswith (name, "PARENT")
7013 || startswith (name, "_parent")));
14f9c5c9
AS
7014}
7015
4c4b4cd2 7016/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 7017 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 7018 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 7019 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 7020 structures. */
14f9c5c9
AS
7021
7022int
ebf56fd3 7023ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 7024{
d2e4a39e 7025 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 7026
dddc0e16
JB
7027 if (name != NULL && strcmp (name, "RETVAL") == 0)
7028 {
7029 /* This happens in functions with "out" or "in out" parameters
7030 which are passed by copy. For such functions, GNAT describes
7031 the function's return type as being a struct where the return
7032 value is in a field called RETVAL, and where the other "out"
7033 or "in out" parameters are fields of that struct. This is not
7034 a wrapper. */
7035 return 0;
7036 }
7037
d2e4a39e 7038 return (name != NULL
61012eef 7039 && (startswith (name, "PARENT")
4c4b4cd2 7040 || strcmp (name, "REP") == 0
61012eef 7041 || startswith (name, "_parent")
4c4b4cd2 7042 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
7043}
7044
4c4b4cd2
PH
7045/* True iff field number FIELD_NUM of structure or union type TYPE
7046 is a variant wrapper. Assumes TYPE is a structure type with at least
7047 FIELD_NUM+1 fields. */
14f9c5c9
AS
7048
7049int
ebf56fd3 7050ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 7051{
d2e4a39e 7052 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 7053
14f9c5c9 7054 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 7055 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
7056 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
7057 == TYPE_CODE_UNION)));
14f9c5c9
AS
7058}
7059
7060/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 7061 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
7062 returns the type of the controlling discriminant for the variant.
7063 May return NULL if the type could not be found. */
14f9c5c9 7064
d2e4a39e 7065struct type *
ebf56fd3 7066ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 7067{
a121b7c1 7068 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 7069
988f6b3d 7070 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
14f9c5c9
AS
7071}
7072
4c4b4cd2 7073/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 7074 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 7075 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
7076
7077int
ebf56fd3 7078ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 7079{
d2e4a39e 7080 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 7081
14f9c5c9
AS
7082 return (name != NULL && name[0] == 'O');
7083}
7084
7085/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
7086 returns the name of the discriminant controlling the variant.
7087 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 7088
a121b7c1 7089const char *
ebf56fd3 7090ada_variant_discrim_name (struct type *type0)
14f9c5c9 7091{
d2e4a39e 7092 static char *result = NULL;
14f9c5c9 7093 static size_t result_len = 0;
d2e4a39e
AS
7094 struct type *type;
7095 const char *name;
7096 const char *discrim_end;
7097 const char *discrim_start;
14f9c5c9
AS
7098
7099 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7100 type = TYPE_TARGET_TYPE (type0);
7101 else
7102 type = type0;
7103
7104 name = ada_type_name (type);
7105
7106 if (name == NULL || name[0] == '\000')
7107 return "";
7108
7109 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7110 discrim_end -= 1)
7111 {
61012eef 7112 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7113 break;
14f9c5c9
AS
7114 }
7115 if (discrim_end == name)
7116 return "";
7117
d2e4a39e 7118 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7119 discrim_start -= 1)
7120 {
d2e4a39e 7121 if (discrim_start == name + 1)
4c4b4cd2 7122 return "";
76a01679 7123 if ((discrim_start > name + 3
61012eef 7124 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7125 || discrim_start[-1] == '.')
7126 break;
14f9c5c9
AS
7127 }
7128
7129 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7130 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7131 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7132 return result;
7133}
7134
4c4b4cd2
PH
7135/* Scan STR for a subtype-encoded number, beginning at position K.
7136 Put the position of the character just past the number scanned in
7137 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7138 Return 1 if there was a valid number at the given position, and 0
7139 otherwise. A "subtype-encoded" number consists of the absolute value
7140 in decimal, followed by the letter 'm' to indicate a negative number.
7141 Assumes 0m does not occur. */
14f9c5c9
AS
7142
7143int
d2e4a39e 7144ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7145{
7146 ULONGEST RU;
7147
d2e4a39e 7148 if (!isdigit (str[k]))
14f9c5c9
AS
7149 return 0;
7150
4c4b4cd2 7151 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7152 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7153 LONGEST. */
14f9c5c9
AS
7154 RU = 0;
7155 while (isdigit (str[k]))
7156 {
d2e4a39e 7157 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7158 k += 1;
7159 }
7160
d2e4a39e 7161 if (str[k] == 'm')
14f9c5c9
AS
7162 {
7163 if (R != NULL)
4c4b4cd2 7164 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7165 k += 1;
7166 }
7167 else if (R != NULL)
7168 *R = (LONGEST) RU;
7169
4c4b4cd2 7170 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7171 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7172 number representable as a LONGEST (although either would probably work
7173 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7174 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7175
7176 if (new_k != NULL)
7177 *new_k = k;
7178 return 1;
7179}
7180
4c4b4cd2
PH
7181/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7182 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7183 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7184
d2e4a39e 7185int
ebf56fd3 7186ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7187{
d2e4a39e 7188 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7189 int p;
7190
7191 p = 0;
7192 while (1)
7193 {
d2e4a39e 7194 switch (name[p])
4c4b4cd2
PH
7195 {
7196 case '\0':
7197 return 0;
7198 case 'S':
7199 {
7200 LONGEST W;
5b4ee69b 7201
4c4b4cd2
PH
7202 if (!ada_scan_number (name, p + 1, &W, &p))
7203 return 0;
7204 if (val == W)
7205 return 1;
7206 break;
7207 }
7208 case 'R':
7209 {
7210 LONGEST L, U;
5b4ee69b 7211
4c4b4cd2
PH
7212 if (!ada_scan_number (name, p + 1, &L, &p)
7213 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7214 return 0;
7215 if (val >= L && val <= U)
7216 return 1;
7217 break;
7218 }
7219 case 'O':
7220 return 1;
7221 default:
7222 return 0;
7223 }
7224 }
7225}
7226
0963b4bd 7227/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7228
7229/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7230 ARG_TYPE, extract and return the value of one of its (non-static)
7231 fields. FIELDNO says which field. Differs from value_primitive_field
7232 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7233
4c4b4cd2 7234static struct value *
d2e4a39e 7235ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7236 struct type *arg_type)
14f9c5c9 7237{
14f9c5c9
AS
7238 struct type *type;
7239
61ee279c 7240 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7241 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7242
4c4b4cd2 7243 /* Handle packed fields. */
14f9c5c9
AS
7244
7245 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7246 {
7247 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7248 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7249
0fd88904 7250 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7251 offset + bit_pos / 8,
7252 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7253 }
7254 else
7255 return value_primitive_field (arg1, offset, fieldno, arg_type);
7256}
7257
52ce6436
PH
7258/* Find field with name NAME in object of type TYPE. If found,
7259 set the following for each argument that is non-null:
7260 - *FIELD_TYPE_P to the field's type;
7261 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7262 an object of that type;
7263 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7264 - *BIT_SIZE_P to its size in bits if the field is packed, and
7265 0 otherwise;
7266 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7267 fields up to but not including the desired field, or by the total
7268 number of fields if not found. A NULL value of NAME never
7269 matches; the function just counts visible fields in this case.
7270
0963b4bd 7271 Returns 1 if found, 0 otherwise. */
52ce6436 7272
4c4b4cd2 7273static int
0d5cff50 7274find_struct_field (const char *name, struct type *type, int offset,
76a01679 7275 struct type **field_type_p,
52ce6436
PH
7276 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7277 int *index_p)
4c4b4cd2
PH
7278{
7279 int i;
7280
61ee279c 7281 type = ada_check_typedef (type);
76a01679 7282
52ce6436
PH
7283 if (field_type_p != NULL)
7284 *field_type_p = NULL;
7285 if (byte_offset_p != NULL)
d5d6fca5 7286 *byte_offset_p = 0;
52ce6436
PH
7287 if (bit_offset_p != NULL)
7288 *bit_offset_p = 0;
7289 if (bit_size_p != NULL)
7290 *bit_size_p = 0;
7291
7292 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7293 {
7294 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7295 int fld_offset = offset + bit_pos / 8;
0d5cff50 7296 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7297
4c4b4cd2
PH
7298 if (t_field_name == NULL)
7299 continue;
7300
52ce6436 7301 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7302 {
7303 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7304
52ce6436
PH
7305 if (field_type_p != NULL)
7306 *field_type_p = TYPE_FIELD_TYPE (type, i);
7307 if (byte_offset_p != NULL)
7308 *byte_offset_p = fld_offset;
7309 if (bit_offset_p != NULL)
7310 *bit_offset_p = bit_pos % 8;
7311 if (bit_size_p != NULL)
7312 *bit_size_p = bit_size;
76a01679
JB
7313 return 1;
7314 }
4c4b4cd2
PH
7315 else if (ada_is_wrapper_field (type, i))
7316 {
52ce6436
PH
7317 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7318 field_type_p, byte_offset_p, bit_offset_p,
7319 bit_size_p, index_p))
76a01679
JB
7320 return 1;
7321 }
4c4b4cd2
PH
7322 else if (ada_is_variant_part (type, i))
7323 {
52ce6436
PH
7324 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7325 fixed type?? */
4c4b4cd2 7326 int j;
52ce6436
PH
7327 struct type *field_type
7328 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7329
52ce6436 7330 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7331 {
76a01679
JB
7332 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7333 fld_offset
7334 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7335 field_type_p, byte_offset_p,
52ce6436 7336 bit_offset_p, bit_size_p, index_p))
76a01679 7337 return 1;
4c4b4cd2
PH
7338 }
7339 }
52ce6436
PH
7340 else if (index_p != NULL)
7341 *index_p += 1;
4c4b4cd2
PH
7342 }
7343 return 0;
7344}
7345
0963b4bd 7346/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7347
52ce6436
PH
7348static int
7349num_visible_fields (struct type *type)
7350{
7351 int n;
5b4ee69b 7352
52ce6436
PH
7353 n = 0;
7354 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7355 return n;
7356}
14f9c5c9 7357
4c4b4cd2 7358/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7359 and search in it assuming it has (class) type TYPE.
7360 If found, return value, else return NULL.
7361
4c4b4cd2 7362 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 7363
4c4b4cd2 7364static struct value *
108d56a4 7365ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7366 struct type *type)
14f9c5c9
AS
7367{
7368 int i;
14f9c5c9 7369
5b4ee69b 7370 type = ada_check_typedef (type);
52ce6436 7371 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7372 {
0d5cff50 7373 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7374
7375 if (t_field_name == NULL)
4c4b4cd2 7376 continue;
14f9c5c9
AS
7377
7378 else if (field_name_match (t_field_name, name))
4c4b4cd2 7379 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7380
7381 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7382 {
0963b4bd 7383 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7384 ada_search_struct_field (name, arg,
7385 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7386 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7387
4c4b4cd2
PH
7388 if (v != NULL)
7389 return v;
7390 }
14f9c5c9
AS
7391
7392 else if (ada_is_variant_part (type, i))
4c4b4cd2 7393 {
0963b4bd 7394 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7395 int j;
5b4ee69b
MS
7396 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7397 i));
4c4b4cd2
PH
7398 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7399
52ce6436 7400 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7401 {
0963b4bd
MS
7402 struct value *v = ada_search_struct_field /* Force line
7403 break. */
06d5cf63
JB
7404 (name, arg,
7405 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7406 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7407
4c4b4cd2
PH
7408 if (v != NULL)
7409 return v;
7410 }
7411 }
14f9c5c9
AS
7412 }
7413 return NULL;
7414}
d2e4a39e 7415
52ce6436
PH
7416static struct value *ada_index_struct_field_1 (int *, struct value *,
7417 int, struct type *);
7418
7419
7420/* Return field #INDEX in ARG, where the index is that returned by
7421 * find_struct_field through its INDEX_P argument. Adjust the address
7422 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7423 * If found, return value, else return NULL. */
52ce6436
PH
7424
7425static struct value *
7426ada_index_struct_field (int index, struct value *arg, int offset,
7427 struct type *type)
7428{
7429 return ada_index_struct_field_1 (&index, arg, offset, type);
7430}
7431
7432
7433/* Auxiliary function for ada_index_struct_field. Like
7434 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7435 * *INDEX_P. */
52ce6436
PH
7436
7437static struct value *
7438ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7439 struct type *type)
7440{
7441 int i;
7442 type = ada_check_typedef (type);
7443
7444 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7445 {
7446 if (TYPE_FIELD_NAME (type, i) == NULL)
7447 continue;
7448 else if (ada_is_wrapper_field (type, i))
7449 {
0963b4bd 7450 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7451 ada_index_struct_field_1 (index_p, arg,
7452 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7453 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7454
52ce6436
PH
7455 if (v != NULL)
7456 return v;
7457 }
7458
7459 else if (ada_is_variant_part (type, i))
7460 {
7461 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7462 find_struct_field. */
52ce6436
PH
7463 error (_("Cannot assign this kind of variant record"));
7464 }
7465 else if (*index_p == 0)
7466 return ada_value_primitive_field (arg, offset, i, type);
7467 else
7468 *index_p -= 1;
7469 }
7470 return NULL;
7471}
7472
4c4b4cd2
PH
7473/* Given ARG, a value of type (pointer or reference to a)*
7474 structure/union, extract the component named NAME from the ultimate
7475 target structure/union and return it as a value with its
f5938064 7476 appropriate type.
14f9c5c9 7477
4c4b4cd2
PH
7478 The routine searches for NAME among all members of the structure itself
7479 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7480 (e.g., '_parent').
7481
03ee6b2e
PH
7482 If NO_ERR, then simply return NULL in case of error, rather than
7483 calling error. */
14f9c5c9 7484
d2e4a39e 7485struct value *
a121b7c1 7486ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7487{
4c4b4cd2 7488 struct type *t, *t1;
d2e4a39e 7489 struct value *v;
14f9c5c9 7490
4c4b4cd2 7491 v = NULL;
df407dfe 7492 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7493 if (TYPE_CODE (t) == TYPE_CODE_REF)
7494 {
7495 t1 = TYPE_TARGET_TYPE (t);
7496 if (t1 == NULL)
03ee6b2e 7497 goto BadValue;
61ee279c 7498 t1 = ada_check_typedef (t1);
4c4b4cd2 7499 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7500 {
994b9211 7501 arg = coerce_ref (arg);
76a01679
JB
7502 t = t1;
7503 }
4c4b4cd2 7504 }
14f9c5c9 7505
4c4b4cd2
PH
7506 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7507 {
7508 t1 = TYPE_TARGET_TYPE (t);
7509 if (t1 == NULL)
03ee6b2e 7510 goto BadValue;
61ee279c 7511 t1 = ada_check_typedef (t1);
4c4b4cd2 7512 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7513 {
7514 arg = value_ind (arg);
7515 t = t1;
7516 }
4c4b4cd2 7517 else
76a01679 7518 break;
4c4b4cd2 7519 }
14f9c5c9 7520
4c4b4cd2 7521 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7522 goto BadValue;
14f9c5c9 7523
4c4b4cd2
PH
7524 if (t1 == t)
7525 v = ada_search_struct_field (name, arg, 0, t);
7526 else
7527 {
7528 int bit_offset, bit_size, byte_offset;
7529 struct type *field_type;
7530 CORE_ADDR address;
7531
76a01679 7532 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7533 address = value_address (ada_value_ind (arg));
4c4b4cd2 7534 else
b50d69b5 7535 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7536
1ed6ede0 7537 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
7538 if (find_struct_field (name, t1, 0,
7539 &field_type, &byte_offset, &bit_offset,
52ce6436 7540 &bit_size, NULL))
76a01679
JB
7541 {
7542 if (bit_size != 0)
7543 {
714e53ab
PH
7544 if (TYPE_CODE (t) == TYPE_CODE_REF)
7545 arg = ada_coerce_ref (arg);
7546 else
7547 arg = ada_value_ind (arg);
76a01679
JB
7548 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7549 bit_offset, bit_size,
7550 field_type);
7551 }
7552 else
f5938064 7553 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7554 }
7555 }
7556
03ee6b2e
PH
7557 if (v != NULL || no_err)
7558 return v;
7559 else
323e0a4a 7560 error (_("There is no member named %s."), name);
14f9c5c9 7561
03ee6b2e
PH
7562 BadValue:
7563 if (no_err)
7564 return NULL;
7565 else
0963b4bd
MS
7566 error (_("Attempt to extract a component of "
7567 "a value that is not a record."));
14f9c5c9
AS
7568}
7569
3b4de39c 7570/* Return a string representation of type TYPE. */
99bbb428 7571
3b4de39c 7572static std::string
99bbb428
PA
7573type_as_string (struct type *type)
7574{
d7e74731 7575 string_file tmp_stream;
99bbb428 7576
d7e74731 7577 type_print (type, "", &tmp_stream, -1);
99bbb428 7578
d7e74731 7579 return std::move (tmp_stream.string ());
99bbb428
PA
7580}
7581
14f9c5c9 7582/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7583 If DISPP is non-null, add its byte displacement from the beginning of a
7584 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7585 work for packed fields).
7586
7587 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7588 followed by "___".
14f9c5c9 7589
0963b4bd 7590 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7591 be a (pointer or reference)+ to a struct or union, and the
7592 ultimate target type will be searched.
14f9c5c9
AS
7593
7594 Looks recursively into variant clauses and parent types.
7595
4c4b4cd2
PH
7596 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7597 TYPE is not a type of the right kind. */
14f9c5c9 7598
4c4b4cd2 7599static struct type *
a121b7c1 7600ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
988f6b3d 7601 int noerr)
14f9c5c9
AS
7602{
7603 int i;
7604
7605 if (name == NULL)
7606 goto BadName;
7607
76a01679 7608 if (refok && type != NULL)
4c4b4cd2
PH
7609 while (1)
7610 {
61ee279c 7611 type = ada_check_typedef (type);
76a01679
JB
7612 if (TYPE_CODE (type) != TYPE_CODE_PTR
7613 && TYPE_CODE (type) != TYPE_CODE_REF)
7614 break;
7615 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7616 }
14f9c5c9 7617
76a01679 7618 if (type == NULL
1265e4aa
JB
7619 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7620 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7621 {
4c4b4cd2 7622 if (noerr)
76a01679 7623 return NULL;
99bbb428 7624
3b4de39c
PA
7625 error (_("Type %s is not a structure or union type"),
7626 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7627 }
7628
7629 type = to_static_fixed_type (type);
7630
7631 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7632 {
0d5cff50 7633 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9 7634 struct type *t;
d2e4a39e 7635
14f9c5c9 7636 if (t_field_name == NULL)
4c4b4cd2 7637 continue;
14f9c5c9
AS
7638
7639 else if (field_name_match (t_field_name, name))
988f6b3d 7640 return TYPE_FIELD_TYPE (type, i);
14f9c5c9
AS
7641
7642 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7643 {
4c4b4cd2 7644 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
988f6b3d 7645 0, 1);
4c4b4cd2 7646 if (t != NULL)
988f6b3d 7647 return t;
4c4b4cd2 7648 }
14f9c5c9
AS
7649
7650 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7651 {
7652 int j;
5b4ee69b
MS
7653 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7654 i));
4c4b4cd2
PH
7655
7656 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7657 {
b1f33ddd
JB
7658 /* FIXME pnh 2008/01/26: We check for a field that is
7659 NOT wrapped in a struct, since the compiler sometimes
7660 generates these for unchecked variant types. Revisit
0963b4bd 7661 if the compiler changes this practice. */
0d5cff50 7662 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
988f6b3d 7663
b1f33ddd
JB
7664 if (v_field_name != NULL
7665 && field_name_match (v_field_name, name))
460efde1 7666 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7667 else
0963b4bd
MS
7668 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7669 j),
988f6b3d 7670 name, 0, 1);
b1f33ddd 7671
4c4b4cd2 7672 if (t != NULL)
988f6b3d 7673 return t;
4c4b4cd2
PH
7674 }
7675 }
14f9c5c9
AS
7676
7677 }
7678
7679BadName:
d2e4a39e 7680 if (!noerr)
14f9c5c9 7681 {
2b2798cc 7682 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7683
7684 error (_("Type %s has no component named %s"),
3b4de39c 7685 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7686 }
7687
7688 return NULL;
7689}
7690
b1f33ddd
JB
7691/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7692 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7693 represents an unchecked union (that is, the variant part of a
0963b4bd 7694 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7695
7696static int
7697is_unchecked_variant (struct type *var_type, struct type *outer_type)
7698{
a121b7c1 7699 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7700
988f6b3d 7701 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
b1f33ddd
JB
7702}
7703
7704
14f9c5c9
AS
7705/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7706 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7707 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7708 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7709
d2e4a39e 7710int
ebf56fd3 7711ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7712 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7713{
7714 int others_clause;
7715 int i;
a121b7c1 7716 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7717 struct value *outer;
7718 struct value *discrim;
14f9c5c9
AS
7719 LONGEST discrim_val;
7720
012370f6
TT
7721 /* Using plain value_from_contents_and_address here causes problems
7722 because we will end up trying to resolve a type that is currently
7723 being constructed. */
7724 outer = value_from_contents_and_address_unresolved (outer_type,
7725 outer_valaddr, 0);
0c281816
JB
7726 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7727 if (discrim == NULL)
14f9c5c9 7728 return -1;
0c281816 7729 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7730
7731 others_clause = -1;
7732 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7733 {
7734 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7735 others_clause = i;
14f9c5c9 7736 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7737 return i;
14f9c5c9
AS
7738 }
7739
7740 return others_clause;
7741}
d2e4a39e 7742\f
14f9c5c9
AS
7743
7744
4c4b4cd2 7745 /* Dynamic-Sized Records */
14f9c5c9
AS
7746
7747/* Strategy: The type ostensibly attached to a value with dynamic size
7748 (i.e., a size that is not statically recorded in the debugging
7749 data) does not accurately reflect the size or layout of the value.
7750 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7751 conventional types that are constructed on the fly. */
14f9c5c9
AS
7752
7753/* There is a subtle and tricky problem here. In general, we cannot
7754 determine the size of dynamic records without its data. However,
7755 the 'struct value' data structure, which GDB uses to represent
7756 quantities in the inferior process (the target), requires the size
7757 of the type at the time of its allocation in order to reserve space
7758 for GDB's internal copy of the data. That's why the
7759 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7760 rather than struct value*s.
14f9c5c9
AS
7761
7762 However, GDB's internal history variables ($1, $2, etc.) are
7763 struct value*s containing internal copies of the data that are not, in
7764 general, the same as the data at their corresponding addresses in
7765 the target. Fortunately, the types we give to these values are all
7766 conventional, fixed-size types (as per the strategy described
7767 above), so that we don't usually have to perform the
7768 'to_fixed_xxx_type' conversions to look at their values.
7769 Unfortunately, there is one exception: if one of the internal
7770 history variables is an array whose elements are unconstrained
7771 records, then we will need to create distinct fixed types for each
7772 element selected. */
7773
7774/* The upshot of all of this is that many routines take a (type, host
7775 address, target address) triple as arguments to represent a value.
7776 The host address, if non-null, is supposed to contain an internal
7777 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7778 target at the target address. */
14f9c5c9
AS
7779
7780/* Assuming that VAL0 represents a pointer value, the result of
7781 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7782 dynamic-sized types. */
14f9c5c9 7783
d2e4a39e
AS
7784struct value *
7785ada_value_ind (struct value *val0)
14f9c5c9 7786{
c48db5ca 7787 struct value *val = value_ind (val0);
5b4ee69b 7788
b50d69b5
JG
7789 if (ada_is_tagged_type (value_type (val), 0))
7790 val = ada_tag_value_at_base_address (val);
7791
4c4b4cd2 7792 return ada_to_fixed_value (val);
14f9c5c9
AS
7793}
7794
7795/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7796 qualifiers on VAL0. */
7797
d2e4a39e
AS
7798static struct value *
7799ada_coerce_ref (struct value *val0)
7800{
df407dfe 7801 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7802 {
7803 struct value *val = val0;
5b4ee69b 7804
994b9211 7805 val = coerce_ref (val);
b50d69b5
JG
7806
7807 if (ada_is_tagged_type (value_type (val), 0))
7808 val = ada_tag_value_at_base_address (val);
7809
4c4b4cd2 7810 return ada_to_fixed_value (val);
d2e4a39e
AS
7811 }
7812 else
14f9c5c9
AS
7813 return val0;
7814}
7815
7816/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7817 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7818
7819static unsigned int
ebf56fd3 7820align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7821{
7822 return (off + alignment - 1) & ~(alignment - 1);
7823}
7824
4c4b4cd2 7825/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7826
7827static unsigned int
ebf56fd3 7828field_alignment (struct type *type, int f)
14f9c5c9 7829{
d2e4a39e 7830 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7831 int len;
14f9c5c9
AS
7832 int align_offset;
7833
64a1bf19
JB
7834 /* The field name should never be null, unless the debugging information
7835 is somehow malformed. In this case, we assume the field does not
7836 require any alignment. */
7837 if (name == NULL)
7838 return 1;
7839
7840 len = strlen (name);
7841
4c4b4cd2
PH
7842 if (!isdigit (name[len - 1]))
7843 return 1;
14f9c5c9 7844
d2e4a39e 7845 if (isdigit (name[len - 2]))
14f9c5c9
AS
7846 align_offset = len - 2;
7847 else
7848 align_offset = len - 1;
7849
61012eef 7850 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7851 return TARGET_CHAR_BIT;
7852
4c4b4cd2
PH
7853 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7854}
7855
852dff6c 7856/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7857
852dff6c
JB
7858static struct symbol *
7859ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7860{
7861 struct symbol *sym;
7862
7863 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7864 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7865 return sym;
7866
4186eb54
KS
7867 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7868 return sym;
14f9c5c9
AS
7869}
7870
dddfab26
UW
7871/* Find a type named NAME. Ignores ambiguity. This routine will look
7872 solely for types defined by debug info, it will not search the GDB
7873 primitive types. */
4c4b4cd2 7874
852dff6c 7875static struct type *
ebf56fd3 7876ada_find_any_type (const char *name)
14f9c5c9 7877{
852dff6c 7878 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7879
14f9c5c9 7880 if (sym != NULL)
dddfab26 7881 return SYMBOL_TYPE (sym);
14f9c5c9 7882
dddfab26 7883 return NULL;
14f9c5c9
AS
7884}
7885
739593e0
JB
7886/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7887 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7888 symbol, in which case it is returned. Otherwise, this looks for
7889 symbols whose name is that of NAME_SYM suffixed with "___XR".
7890 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7891
7892struct symbol *
270140bd 7893ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7894{
739593e0 7895 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7896 struct symbol *sym;
7897
739593e0
JB
7898 if (strstr (name, "___XR") != NULL)
7899 return name_sym;
7900
aeb5907d
JB
7901 sym = find_old_style_renaming_symbol (name, block);
7902
7903 if (sym != NULL)
7904 return sym;
7905
0963b4bd 7906 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7907 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7908 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7909 return sym;
7910 else
7911 return NULL;
7912}
7913
7914static struct symbol *
270140bd 7915find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7916{
7f0df278 7917 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7918 char *rename;
7919
7920 if (function_sym != NULL)
7921 {
7922 /* If the symbol is defined inside a function, NAME is not fully
7923 qualified. This means we need to prepend the function name
7924 as well as adding the ``___XR'' suffix to build the name of
7925 the associated renaming symbol. */
0d5cff50 7926 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7927 /* Function names sometimes contain suffixes used
7928 for instance to qualify nested subprograms. When building
7929 the XR type name, we need to make sure that this suffix is
7930 not included. So do not include any suffix in the function
7931 name length below. */
69fadcdf 7932 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7933 const int rename_len = function_name_len + 2 /* "__" */
7934 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7935
529cad9c 7936 /* Strip the suffix if necessary. */
69fadcdf
JB
7937 ada_remove_trailing_digits (function_name, &function_name_len);
7938 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7939 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7940
4c4b4cd2
PH
7941 /* Library-level functions are a special case, as GNAT adds
7942 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7943 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7944 have this prefix, so we need to skip this prefix if present. */
7945 if (function_name_len > 5 /* "_ada_" */
7946 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7947 {
7948 function_name += 5;
7949 function_name_len -= 5;
7950 }
4c4b4cd2
PH
7951
7952 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7953 strncpy (rename, function_name, function_name_len);
7954 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7955 "__%s___XR", name);
4c4b4cd2
PH
7956 }
7957 else
7958 {
7959 const int rename_len = strlen (name) + 6;
5b4ee69b 7960
4c4b4cd2 7961 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7962 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7963 }
7964
852dff6c 7965 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7966}
7967
14f9c5c9 7968/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7969 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7970 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7971 otherwise return 0. */
7972
14f9c5c9 7973int
d2e4a39e 7974ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7975{
7976 if (type1 == NULL)
7977 return 1;
7978 else if (type0 == NULL)
7979 return 0;
7980 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7981 return 1;
7982 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7983 return 0;
4c4b4cd2
PH
7984 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7985 return 1;
ad82864c 7986 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7987 return 1;
4c4b4cd2
PH
7988 else if (ada_is_array_descriptor_type (type0)
7989 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7990 return 1;
aeb5907d
JB
7991 else
7992 {
7993 const char *type0_name = type_name_no_tag (type0);
7994 const char *type1_name = type_name_no_tag (type1);
7995
7996 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7997 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7998 return 1;
7999 }
14f9c5c9
AS
8000 return 0;
8001}
8002
8003/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
8004 null, its TYPE_TAG_NAME. Null if TYPE is null. */
8005
0d5cff50 8006const char *
d2e4a39e 8007ada_type_name (struct type *type)
14f9c5c9 8008{
d2e4a39e 8009 if (type == NULL)
14f9c5c9
AS
8010 return NULL;
8011 else if (TYPE_NAME (type) != NULL)
8012 return TYPE_NAME (type);
8013 else
8014 return TYPE_TAG_NAME (type);
8015}
8016
b4ba55a1
JB
8017/* Search the list of "descriptive" types associated to TYPE for a type
8018 whose name is NAME. */
8019
8020static struct type *
8021find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8022{
931e5bc3 8023 struct type *result, *tmp;
b4ba55a1 8024
c6044dd1
JB
8025 if (ada_ignore_descriptive_types_p)
8026 return NULL;
8027
b4ba55a1
JB
8028 /* If there no descriptive-type info, then there is no parallel type
8029 to be found. */
8030 if (!HAVE_GNAT_AUX_INFO (type))
8031 return NULL;
8032
8033 result = TYPE_DESCRIPTIVE_TYPE (type);
8034 while (result != NULL)
8035 {
0d5cff50 8036 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8037
8038 if (result_name == NULL)
8039 {
8040 warning (_("unexpected null name on descriptive type"));
8041 return NULL;
8042 }
8043
8044 /* If the names match, stop. */
8045 if (strcmp (result_name, name) == 0)
8046 break;
8047
8048 /* Otherwise, look at the next item on the list, if any. */
8049 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8050 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8051 else
8052 tmp = NULL;
8053
8054 /* If not found either, try after having resolved the typedef. */
8055 if (tmp != NULL)
8056 result = tmp;
b4ba55a1 8057 else
931e5bc3 8058 {
f168693b 8059 result = check_typedef (result);
931e5bc3
JG
8060 if (HAVE_GNAT_AUX_INFO (result))
8061 result = TYPE_DESCRIPTIVE_TYPE (result);
8062 else
8063 result = NULL;
8064 }
b4ba55a1
JB
8065 }
8066
8067 /* If we didn't find a match, see whether this is a packed array. With
8068 older compilers, the descriptive type information is either absent or
8069 irrelevant when it comes to packed arrays so the above lookup fails.
8070 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8071 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8072 return ada_find_any_type (name);
8073
8074 return result;
8075}
8076
8077/* Find a parallel type to TYPE with the specified NAME, using the
8078 descriptive type taken from the debugging information, if available,
8079 and otherwise using the (slower) name-based method. */
8080
8081static struct type *
8082ada_find_parallel_type_with_name (struct type *type, const char *name)
8083{
8084 struct type *result = NULL;
8085
8086 if (HAVE_GNAT_AUX_INFO (type))
8087 result = find_parallel_type_by_descriptive_type (type, name);
8088 else
8089 result = ada_find_any_type (name);
8090
8091 return result;
8092}
8093
8094/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8095 SUFFIX to the name of TYPE. */
14f9c5c9 8096
d2e4a39e 8097struct type *
ebf56fd3 8098ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8099{
0d5cff50 8100 char *name;
fe978cb0 8101 const char *type_name = ada_type_name (type);
14f9c5c9 8102 int len;
d2e4a39e 8103
fe978cb0 8104 if (type_name == NULL)
14f9c5c9
AS
8105 return NULL;
8106
fe978cb0 8107 len = strlen (type_name);
14f9c5c9 8108
b4ba55a1 8109 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8110
fe978cb0 8111 strcpy (name, type_name);
14f9c5c9
AS
8112 strcpy (name + len, suffix);
8113
b4ba55a1 8114 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8115}
8116
14f9c5c9 8117/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8118 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8119
d2e4a39e
AS
8120static struct type *
8121dynamic_template_type (struct type *type)
14f9c5c9 8122{
61ee279c 8123 type = ada_check_typedef (type);
14f9c5c9
AS
8124
8125 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8126 || ada_type_name (type) == NULL)
14f9c5c9 8127 return NULL;
d2e4a39e 8128 else
14f9c5c9
AS
8129 {
8130 int len = strlen (ada_type_name (type));
5b4ee69b 8131
4c4b4cd2
PH
8132 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8133 return type;
14f9c5c9 8134 else
4c4b4cd2 8135 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8136 }
8137}
8138
8139/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8140 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8141
d2e4a39e
AS
8142static int
8143is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8144{
8145 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8146
d2e4a39e 8147 return name != NULL
14f9c5c9
AS
8148 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8149 && strstr (name, "___XVL") != NULL;
8150}
8151
4c4b4cd2
PH
8152/* The index of the variant field of TYPE, or -1 if TYPE does not
8153 represent a variant record type. */
14f9c5c9 8154
d2e4a39e 8155static int
4c4b4cd2 8156variant_field_index (struct type *type)
14f9c5c9
AS
8157{
8158 int f;
8159
4c4b4cd2
PH
8160 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8161 return -1;
8162
8163 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8164 {
8165 if (ada_is_variant_part (type, f))
8166 return f;
8167 }
8168 return -1;
14f9c5c9
AS
8169}
8170
4c4b4cd2
PH
8171/* A record type with no fields. */
8172
d2e4a39e 8173static struct type *
fe978cb0 8174empty_record (struct type *templ)
14f9c5c9 8175{
fe978cb0 8176 struct type *type = alloc_type_copy (templ);
5b4ee69b 8177
14f9c5c9
AS
8178 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8179 TYPE_NFIELDS (type) = 0;
8180 TYPE_FIELDS (type) = NULL;
b1f33ddd 8181 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
8182 TYPE_NAME (type) = "<empty>";
8183 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
8184 TYPE_LENGTH (type) = 0;
8185 return type;
8186}
8187
8188/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8189 the value of type TYPE at VALADDR or ADDRESS (see comments at
8190 the beginning of this section) VAL according to GNAT conventions.
8191 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8192 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8193 an outer-level type (i.e., as opposed to a branch of a variant.) A
8194 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8195 of the variant.
14f9c5c9 8196
4c4b4cd2
PH
8197 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8198 length are not statically known are discarded. As a consequence,
8199 VALADDR, ADDRESS and DVAL0 are ignored.
8200
8201 NOTE: Limitations: For now, we assume that dynamic fields and
8202 variants occupy whole numbers of bytes. However, they need not be
8203 byte-aligned. */
8204
8205struct type *
10a2c479 8206ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8207 const gdb_byte *valaddr,
4c4b4cd2
PH
8208 CORE_ADDR address, struct value *dval0,
8209 int keep_dynamic_fields)
14f9c5c9 8210{
d2e4a39e
AS
8211 struct value *mark = value_mark ();
8212 struct value *dval;
8213 struct type *rtype;
14f9c5c9 8214 int nfields, bit_len;
4c4b4cd2 8215 int variant_field;
14f9c5c9 8216 long off;
d94e4f4f 8217 int fld_bit_len;
14f9c5c9
AS
8218 int f;
8219
4c4b4cd2
PH
8220 /* Compute the number of fields in this record type that are going
8221 to be processed: unless keep_dynamic_fields, this includes only
8222 fields whose position and length are static will be processed. */
8223 if (keep_dynamic_fields)
8224 nfields = TYPE_NFIELDS (type);
8225 else
8226 {
8227 nfields = 0;
76a01679 8228 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8229 && !ada_is_variant_part (type, nfields)
8230 && !is_dynamic_field (type, nfields))
8231 nfields++;
8232 }
8233
e9bb382b 8234 rtype = alloc_type_copy (type);
14f9c5c9
AS
8235 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8236 INIT_CPLUS_SPECIFIC (rtype);
8237 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8238 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8239 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8240 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8241 TYPE_NAME (rtype) = ada_type_name (type);
8242 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8243 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8244
d2e4a39e
AS
8245 off = 0;
8246 bit_len = 0;
4c4b4cd2
PH
8247 variant_field = -1;
8248
14f9c5c9
AS
8249 for (f = 0; f < nfields; f += 1)
8250 {
6c038f32
PH
8251 off = align_value (off, field_alignment (type, f))
8252 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8253 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8254 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8255
d2e4a39e 8256 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8257 {
8258 variant_field = f;
d94e4f4f 8259 fld_bit_len = 0;
4c4b4cd2 8260 }
14f9c5c9 8261 else if (is_dynamic_field (type, f))
4c4b4cd2 8262 {
284614f0
JB
8263 const gdb_byte *field_valaddr = valaddr;
8264 CORE_ADDR field_address = address;
8265 struct type *field_type =
8266 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8267
4c4b4cd2 8268 if (dval0 == NULL)
b5304971
JG
8269 {
8270 /* rtype's length is computed based on the run-time
8271 value of discriminants. If the discriminants are not
8272 initialized, the type size may be completely bogus and
0963b4bd 8273 GDB may fail to allocate a value for it. So check the
b5304971 8274 size first before creating the value. */
c1b5a1a6 8275 ada_ensure_varsize_limit (rtype);
012370f6
TT
8276 /* Using plain value_from_contents_and_address here
8277 causes problems because we will end up trying to
8278 resolve a type that is currently being
8279 constructed. */
8280 dval = value_from_contents_and_address_unresolved (rtype,
8281 valaddr,
8282 address);
9f1f738a 8283 rtype = value_type (dval);
b5304971 8284 }
4c4b4cd2
PH
8285 else
8286 dval = dval0;
8287
284614f0
JB
8288 /* If the type referenced by this field is an aligner type, we need
8289 to unwrap that aligner type, because its size might not be set.
8290 Keeping the aligner type would cause us to compute the wrong
8291 size for this field, impacting the offset of the all the fields
8292 that follow this one. */
8293 if (ada_is_aligner_type (field_type))
8294 {
8295 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8296
8297 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8298 field_address = cond_offset_target (field_address, field_offset);
8299 field_type = ada_aligned_type (field_type);
8300 }
8301
8302 field_valaddr = cond_offset_host (field_valaddr,
8303 off / TARGET_CHAR_BIT);
8304 field_address = cond_offset_target (field_address,
8305 off / TARGET_CHAR_BIT);
8306
8307 /* Get the fixed type of the field. Note that, in this case,
8308 we do not want to get the real type out of the tag: if
8309 the current field is the parent part of a tagged record,
8310 we will get the tag of the object. Clearly wrong: the real
8311 type of the parent is not the real type of the child. We
8312 would end up in an infinite loop. */
8313 field_type = ada_get_base_type (field_type);
8314 field_type = ada_to_fixed_type (field_type, field_valaddr,
8315 field_address, dval, 0);
27f2a97b
JB
8316 /* If the field size is already larger than the maximum
8317 object size, then the record itself will necessarily
8318 be larger than the maximum object size. We need to make
8319 this check now, because the size might be so ridiculously
8320 large (due to an uninitialized variable in the inferior)
8321 that it would cause an overflow when adding it to the
8322 record size. */
c1b5a1a6 8323 ada_ensure_varsize_limit (field_type);
284614f0
JB
8324
8325 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8326 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8327 /* The multiplication can potentially overflow. But because
8328 the field length has been size-checked just above, and
8329 assuming that the maximum size is a reasonable value,
8330 an overflow should not happen in practice. So rather than
8331 adding overflow recovery code to this already complex code,
8332 we just assume that it's not going to happen. */
d94e4f4f 8333 fld_bit_len =
4c4b4cd2
PH
8334 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8335 }
14f9c5c9 8336 else
4c4b4cd2 8337 {
5ded5331
JB
8338 /* Note: If this field's type is a typedef, it is important
8339 to preserve the typedef layer.
8340
8341 Otherwise, we might be transforming a typedef to a fat
8342 pointer (encoding a pointer to an unconstrained array),
8343 into a basic fat pointer (encoding an unconstrained
8344 array). As both types are implemented using the same
8345 structure, the typedef is the only clue which allows us
8346 to distinguish between the two options. Stripping it
8347 would prevent us from printing this field appropriately. */
8348 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8349 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8350 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8351 fld_bit_len =
4c4b4cd2
PH
8352 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8353 else
5ded5331
JB
8354 {
8355 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8356
8357 /* We need to be careful of typedefs when computing
8358 the length of our field. If this is a typedef,
8359 get the length of the target type, not the length
8360 of the typedef. */
8361 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8362 field_type = ada_typedef_target_type (field_type);
8363
8364 fld_bit_len =
8365 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8366 }
4c4b4cd2 8367 }
14f9c5c9 8368 if (off + fld_bit_len > bit_len)
4c4b4cd2 8369 bit_len = off + fld_bit_len;
d94e4f4f 8370 off += fld_bit_len;
4c4b4cd2
PH
8371 TYPE_LENGTH (rtype) =
8372 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8373 }
4c4b4cd2
PH
8374
8375 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8376 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8377 the record. This can happen in the presence of representation
8378 clauses. */
8379 if (variant_field >= 0)
8380 {
8381 struct type *branch_type;
8382
8383 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8384
8385 if (dval0 == NULL)
9f1f738a 8386 {
012370f6
TT
8387 /* Using plain value_from_contents_and_address here causes
8388 problems because we will end up trying to resolve a type
8389 that is currently being constructed. */
8390 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8391 address);
9f1f738a
SA
8392 rtype = value_type (dval);
8393 }
4c4b4cd2
PH
8394 else
8395 dval = dval0;
8396
8397 branch_type =
8398 to_fixed_variant_branch_type
8399 (TYPE_FIELD_TYPE (type, variant_field),
8400 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8401 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8402 if (branch_type == NULL)
8403 {
8404 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8405 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8406 TYPE_NFIELDS (rtype) -= 1;
8407 }
8408 else
8409 {
8410 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8411 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8412 fld_bit_len =
8413 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8414 TARGET_CHAR_BIT;
8415 if (off + fld_bit_len > bit_len)
8416 bit_len = off + fld_bit_len;
8417 TYPE_LENGTH (rtype) =
8418 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8419 }
8420 }
8421
714e53ab
PH
8422 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8423 should contain the alignment of that record, which should be a strictly
8424 positive value. If null or negative, then something is wrong, most
8425 probably in the debug info. In that case, we don't round up the size
0963b4bd 8426 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8427 the current RTYPE length might be good enough for our purposes. */
8428 if (TYPE_LENGTH (type) <= 0)
8429 {
323e0a4a
AC
8430 if (TYPE_NAME (rtype))
8431 warning (_("Invalid type size for `%s' detected: %d."),
8432 TYPE_NAME (rtype), TYPE_LENGTH (type));
8433 else
8434 warning (_("Invalid type size for <unnamed> detected: %d."),
8435 TYPE_LENGTH (type));
714e53ab
PH
8436 }
8437 else
8438 {
8439 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8440 TYPE_LENGTH (type));
8441 }
14f9c5c9
AS
8442
8443 value_free_to_mark (mark);
d2e4a39e 8444 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8445 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8446 return rtype;
8447}
8448
4c4b4cd2
PH
8449/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8450 of 1. */
14f9c5c9 8451
d2e4a39e 8452static struct type *
fc1a4b47 8453template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8454 CORE_ADDR address, struct value *dval0)
8455{
8456 return ada_template_to_fixed_record_type_1 (type, valaddr,
8457 address, dval0, 1);
8458}
8459
8460/* An ordinary record type in which ___XVL-convention fields and
8461 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8462 static approximations, containing all possible fields. Uses
8463 no runtime values. Useless for use in values, but that's OK,
8464 since the results are used only for type determinations. Works on both
8465 structs and unions. Representation note: to save space, we memorize
8466 the result of this function in the TYPE_TARGET_TYPE of the
8467 template type. */
8468
8469static struct type *
8470template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8471{
8472 struct type *type;
8473 int nfields;
8474 int f;
8475
9e195661
PMR
8476 /* No need no do anything if the input type is already fixed. */
8477 if (TYPE_FIXED_INSTANCE (type0))
8478 return type0;
8479
8480 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8481 if (TYPE_TARGET_TYPE (type0) != NULL)
8482 return TYPE_TARGET_TYPE (type0);
8483
9e195661 8484 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8485 type = type0;
9e195661
PMR
8486 nfields = TYPE_NFIELDS (type0);
8487
8488 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8489 recompute all over next time. */
8490 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8491
8492 for (f = 0; f < nfields; f += 1)
8493 {
460efde1 8494 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8495 struct type *new_type;
14f9c5c9 8496
4c4b4cd2 8497 if (is_dynamic_field (type0, f))
460efde1
JB
8498 {
8499 field_type = ada_check_typedef (field_type);
8500 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8501 }
14f9c5c9 8502 else
f192137b 8503 new_type = static_unwrap_type (field_type);
9e195661
PMR
8504
8505 if (new_type != field_type)
8506 {
8507 /* Clone TYPE0 only the first time we get a new field type. */
8508 if (type == type0)
8509 {
8510 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8511 TYPE_CODE (type) = TYPE_CODE (type0);
8512 INIT_CPLUS_SPECIFIC (type);
8513 TYPE_NFIELDS (type) = nfields;
8514 TYPE_FIELDS (type) = (struct field *)
8515 TYPE_ALLOC (type, nfields * sizeof (struct field));
8516 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8517 sizeof (struct field) * nfields);
8518 TYPE_NAME (type) = ada_type_name (type0);
8519 TYPE_TAG_NAME (type) = NULL;
8520 TYPE_FIXED_INSTANCE (type) = 1;
8521 TYPE_LENGTH (type) = 0;
8522 }
8523 TYPE_FIELD_TYPE (type, f) = new_type;
8524 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8525 }
14f9c5c9 8526 }
9e195661 8527
14f9c5c9
AS
8528 return type;
8529}
8530
4c4b4cd2 8531/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8532 whose address in memory is ADDRESS, returns a revision of TYPE,
8533 which should be a non-dynamic-sized record, in which the variant
8534 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8535 for discriminant values in DVAL0, which can be NULL if the record
8536 contains the necessary discriminant values. */
8537
d2e4a39e 8538static struct type *
fc1a4b47 8539to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8540 CORE_ADDR address, struct value *dval0)
14f9c5c9 8541{
d2e4a39e 8542 struct value *mark = value_mark ();
4c4b4cd2 8543 struct value *dval;
d2e4a39e 8544 struct type *rtype;
14f9c5c9
AS
8545 struct type *branch_type;
8546 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8547 int variant_field = variant_field_index (type);
14f9c5c9 8548
4c4b4cd2 8549 if (variant_field == -1)
14f9c5c9
AS
8550 return type;
8551
4c4b4cd2 8552 if (dval0 == NULL)
9f1f738a
SA
8553 {
8554 dval = value_from_contents_and_address (type, valaddr, address);
8555 type = value_type (dval);
8556 }
4c4b4cd2
PH
8557 else
8558 dval = dval0;
8559
e9bb382b 8560 rtype = alloc_type_copy (type);
14f9c5c9 8561 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8562 INIT_CPLUS_SPECIFIC (rtype);
8563 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8564 TYPE_FIELDS (rtype) =
8565 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8566 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8567 sizeof (struct field) * nfields);
14f9c5c9
AS
8568 TYPE_NAME (rtype) = ada_type_name (type);
8569 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8570 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8571 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8572
4c4b4cd2
PH
8573 branch_type = to_fixed_variant_branch_type
8574 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8575 cond_offset_host (valaddr,
4c4b4cd2
PH
8576 TYPE_FIELD_BITPOS (type, variant_field)
8577 / TARGET_CHAR_BIT),
d2e4a39e 8578 cond_offset_target (address,
4c4b4cd2
PH
8579 TYPE_FIELD_BITPOS (type, variant_field)
8580 / TARGET_CHAR_BIT), dval);
d2e4a39e 8581 if (branch_type == NULL)
14f9c5c9 8582 {
4c4b4cd2 8583 int f;
5b4ee69b 8584
4c4b4cd2
PH
8585 for (f = variant_field + 1; f < nfields; f += 1)
8586 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8587 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8588 }
8589 else
8590 {
4c4b4cd2
PH
8591 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8592 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8593 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8594 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8595 }
4c4b4cd2 8596 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8597
4c4b4cd2 8598 value_free_to_mark (mark);
14f9c5c9
AS
8599 return rtype;
8600}
8601
8602/* An ordinary record type (with fixed-length fields) that describes
8603 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8604 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8605 should be in DVAL, a record value; it may be NULL if the object
8606 at ADDR itself contains any necessary discriminant values.
8607 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8608 values from the record are needed. Except in the case that DVAL,
8609 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8610 unchecked) is replaced by a particular branch of the variant.
8611
8612 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8613 is questionable and may be removed. It can arise during the
8614 processing of an unconstrained-array-of-record type where all the
8615 variant branches have exactly the same size. This is because in
8616 such cases, the compiler does not bother to use the XVS convention
8617 when encoding the record. I am currently dubious of this
8618 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8619
d2e4a39e 8620static struct type *
fc1a4b47 8621to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8622 CORE_ADDR address, struct value *dval)
14f9c5c9 8623{
d2e4a39e 8624 struct type *templ_type;
14f9c5c9 8625
876cecd0 8626 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8627 return type0;
8628
d2e4a39e 8629 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8630
8631 if (templ_type != NULL)
8632 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8633 else if (variant_field_index (type0) >= 0)
8634 {
8635 if (dval == NULL && valaddr == NULL && address == 0)
8636 return type0;
8637 return to_record_with_fixed_variant_part (type0, valaddr, address,
8638 dval);
8639 }
14f9c5c9
AS
8640 else
8641 {
876cecd0 8642 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8643 return type0;
8644 }
8645
8646}
8647
8648/* An ordinary record type (with fixed-length fields) that describes
8649 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8650 union type. Any necessary discriminants' values should be in DVAL,
8651 a record value. That is, this routine selects the appropriate
8652 branch of the union at ADDR according to the discriminant value
b1f33ddd 8653 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8654 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8655
d2e4a39e 8656static struct type *
fc1a4b47 8657to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8658 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8659{
8660 int which;
d2e4a39e
AS
8661 struct type *templ_type;
8662 struct type *var_type;
14f9c5c9
AS
8663
8664 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8665 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8666 else
14f9c5c9
AS
8667 var_type = var_type0;
8668
8669 templ_type = ada_find_parallel_type (var_type, "___XVU");
8670
8671 if (templ_type != NULL)
8672 var_type = templ_type;
8673
b1f33ddd
JB
8674 if (is_unchecked_variant (var_type, value_type (dval)))
8675 return var_type0;
d2e4a39e
AS
8676 which =
8677 ada_which_variant_applies (var_type,
0fd88904 8678 value_type (dval), value_contents (dval));
14f9c5c9
AS
8679
8680 if (which < 0)
e9bb382b 8681 return empty_record (var_type);
14f9c5c9 8682 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8683 return to_fixed_record_type
d2e4a39e
AS
8684 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8685 valaddr, address, dval);
4c4b4cd2 8686 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8687 return
8688 to_fixed_record_type
8689 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8690 else
8691 return TYPE_FIELD_TYPE (var_type, which);
8692}
8693
8908fca5
JB
8694/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8695 ENCODING_TYPE, a type following the GNAT conventions for discrete
8696 type encodings, only carries redundant information. */
8697
8698static int
8699ada_is_redundant_range_encoding (struct type *range_type,
8700 struct type *encoding_type)
8701{
8702 struct type *fixed_range_type;
108d56a4 8703 const char *bounds_str;
8908fca5
JB
8704 int n;
8705 LONGEST lo, hi;
8706
8707 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8708
005e2509
JB
8709 if (TYPE_CODE (get_base_type (range_type))
8710 != TYPE_CODE (get_base_type (encoding_type)))
8711 {
8712 /* The compiler probably used a simple base type to describe
8713 the range type instead of the range's actual base type,
8714 expecting us to get the real base type from the encoding
8715 anyway. In this situation, the encoding cannot be ignored
8716 as redundant. */
8717 return 0;
8718 }
8719
8908fca5
JB
8720 if (is_dynamic_type (range_type))
8721 return 0;
8722
8723 if (TYPE_NAME (encoding_type) == NULL)
8724 return 0;
8725
8726 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8727 if (bounds_str == NULL)
8728 return 0;
8729
8730 n = 8; /* Skip "___XDLU_". */
8731 if (!ada_scan_number (bounds_str, n, &lo, &n))
8732 return 0;
8733 if (TYPE_LOW_BOUND (range_type) != lo)
8734 return 0;
8735
8736 n += 2; /* Skip the "__" separator between the two bounds. */
8737 if (!ada_scan_number (bounds_str, n, &hi, &n))
8738 return 0;
8739 if (TYPE_HIGH_BOUND (range_type) != hi)
8740 return 0;
8741
8742 return 1;
8743}
8744
8745/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8746 a type following the GNAT encoding for describing array type
8747 indices, only carries redundant information. */
8748
8749static int
8750ada_is_redundant_index_type_desc (struct type *array_type,
8751 struct type *desc_type)
8752{
8753 struct type *this_layer = check_typedef (array_type);
8754 int i;
8755
8756 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8757 {
8758 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8759 TYPE_FIELD_TYPE (desc_type, i)))
8760 return 0;
8761 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8762 }
8763
8764 return 1;
8765}
8766
14f9c5c9
AS
8767/* Assuming that TYPE0 is an array type describing the type of a value
8768 at ADDR, and that DVAL describes a record containing any
8769 discriminants used in TYPE0, returns a type for the value that
8770 contains no dynamic components (that is, no components whose sizes
8771 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8772 true, gives an error message if the resulting type's size is over
4c4b4cd2 8773 varsize_limit. */
14f9c5c9 8774
d2e4a39e
AS
8775static struct type *
8776to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8777 int ignore_too_big)
14f9c5c9 8778{
d2e4a39e
AS
8779 struct type *index_type_desc;
8780 struct type *result;
ad82864c 8781 int constrained_packed_array_p;
931e5bc3 8782 static const char *xa_suffix = "___XA";
14f9c5c9 8783
b0dd7688 8784 type0 = ada_check_typedef (type0);
284614f0 8785 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8786 return type0;
14f9c5c9 8787
ad82864c
JB
8788 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8789 if (constrained_packed_array_p)
8790 type0 = decode_constrained_packed_array_type (type0);
284614f0 8791
931e5bc3
JG
8792 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8793
8794 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8795 encoding suffixed with 'P' may still be generated. If so,
8796 it should be used to find the XA type. */
8797
8798 if (index_type_desc == NULL)
8799 {
1da0522e 8800 const char *type_name = ada_type_name (type0);
931e5bc3 8801
1da0522e 8802 if (type_name != NULL)
931e5bc3 8803 {
1da0522e 8804 const int len = strlen (type_name);
931e5bc3
JG
8805 char *name = (char *) alloca (len + strlen (xa_suffix));
8806
1da0522e 8807 if (type_name[len - 1] == 'P')
931e5bc3 8808 {
1da0522e 8809 strcpy (name, type_name);
931e5bc3
JG
8810 strcpy (name + len - 1, xa_suffix);
8811 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8812 }
8813 }
8814 }
8815
28c85d6c 8816 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8817 if (index_type_desc != NULL
8818 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8819 {
8820 /* Ignore this ___XA parallel type, as it does not bring any
8821 useful information. This allows us to avoid creating fixed
8822 versions of the array's index types, which would be identical
8823 to the original ones. This, in turn, can also help avoid
8824 the creation of fixed versions of the array itself. */
8825 index_type_desc = NULL;
8826 }
8827
14f9c5c9
AS
8828 if (index_type_desc == NULL)
8829 {
61ee279c 8830 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8831
14f9c5c9 8832 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8833 depend on the contents of the array in properly constructed
8834 debugging data. */
529cad9c
PH
8835 /* Create a fixed version of the array element type.
8836 We're not providing the address of an element here,
e1d5a0d2 8837 and thus the actual object value cannot be inspected to do
529cad9c
PH
8838 the conversion. This should not be a problem, since arrays of
8839 unconstrained objects are not allowed. In particular, all
8840 the elements of an array of a tagged type should all be of
8841 the same type specified in the debugging info. No need to
8842 consult the object tag. */
1ed6ede0 8843 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8844
284614f0
JB
8845 /* Make sure we always create a new array type when dealing with
8846 packed array types, since we're going to fix-up the array
8847 type length and element bitsize a little further down. */
ad82864c 8848 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8849 result = type0;
14f9c5c9 8850 else
e9bb382b 8851 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8852 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8853 }
8854 else
8855 {
8856 int i;
8857 struct type *elt_type0;
8858
8859 elt_type0 = type0;
8860 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8861 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8862
8863 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8864 depend on the contents of the array in properly constructed
8865 debugging data. */
529cad9c
PH
8866 /* Create a fixed version of the array element type.
8867 We're not providing the address of an element here,
e1d5a0d2 8868 and thus the actual object value cannot be inspected to do
529cad9c
PH
8869 the conversion. This should not be a problem, since arrays of
8870 unconstrained objects are not allowed. In particular, all
8871 the elements of an array of a tagged type should all be of
8872 the same type specified in the debugging info. No need to
8873 consult the object tag. */
1ed6ede0
JB
8874 result =
8875 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8876
8877 elt_type0 = type0;
14f9c5c9 8878 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8879 {
8880 struct type *range_type =
28c85d6c 8881 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8882
e9bb382b 8883 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8884 result, range_type);
1ce677a4 8885 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8886 }
d2e4a39e 8887 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8888 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8889 }
8890
2e6fda7d
JB
8891 /* We want to preserve the type name. This can be useful when
8892 trying to get the type name of a value that has already been
8893 printed (for instance, if the user did "print VAR; whatis $". */
8894 TYPE_NAME (result) = TYPE_NAME (type0);
8895
ad82864c 8896 if (constrained_packed_array_p)
284614f0
JB
8897 {
8898 /* So far, the resulting type has been created as if the original
8899 type was a regular (non-packed) array type. As a result, the
8900 bitsize of the array elements needs to be set again, and the array
8901 length needs to be recomputed based on that bitsize. */
8902 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8903 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8904
8905 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8906 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8907 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8908 TYPE_LENGTH (result)++;
8909 }
8910
876cecd0 8911 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8912 return result;
d2e4a39e 8913}
14f9c5c9
AS
8914
8915
8916/* A standard type (containing no dynamically sized components)
8917 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8918 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8919 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8920 ADDRESS or in VALADDR contains these discriminants.
8921
1ed6ede0
JB
8922 If CHECK_TAG is not null, in the case of tagged types, this function
8923 attempts to locate the object's tag and use it to compute the actual
8924 type. However, when ADDRESS is null, we cannot use it to determine the
8925 location of the tag, and therefore compute the tagged type's actual type.
8926 So we return the tagged type without consulting the tag. */
529cad9c 8927
f192137b
JB
8928static struct type *
8929ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8930 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8931{
61ee279c 8932 type = ada_check_typedef (type);
d2e4a39e
AS
8933 switch (TYPE_CODE (type))
8934 {
8935 default:
14f9c5c9 8936 return type;
d2e4a39e 8937 case TYPE_CODE_STRUCT:
4c4b4cd2 8938 {
76a01679 8939 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8940 struct type *fixed_record_type =
8941 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8942
529cad9c
PH
8943 /* If STATIC_TYPE is a tagged type and we know the object's address,
8944 then we can determine its tag, and compute the object's actual
0963b4bd 8945 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8946 type (the parent part of the record may have dynamic fields
8947 and the way the location of _tag is expressed may depend on
8948 them). */
529cad9c 8949
1ed6ede0 8950 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8951 {
b50d69b5
JG
8952 struct value *tag =
8953 value_tag_from_contents_and_address
8954 (fixed_record_type,
8955 valaddr,
8956 address);
8957 struct type *real_type = type_from_tag (tag);
8958 struct value *obj =
8959 value_from_contents_and_address (fixed_record_type,
8960 valaddr,
8961 address);
9f1f738a 8962 fixed_record_type = value_type (obj);
76a01679 8963 if (real_type != NULL)
b50d69b5
JG
8964 return to_fixed_record_type
8965 (real_type, NULL,
8966 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8967 }
4af88198
JB
8968
8969 /* Check to see if there is a parallel ___XVZ variable.
8970 If there is, then it provides the actual size of our type. */
8971 else if (ada_type_name (fixed_record_type) != NULL)
8972 {
0d5cff50 8973 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
8974 char *xvz_name
8975 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
4af88198
JB
8976 LONGEST size;
8977
88c15c34 8978 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
edb0c9cb
PA
8979 if (get_int_var_value (xvz_name, size)
8980 && TYPE_LENGTH (fixed_record_type) != size)
4af88198
JB
8981 {
8982 fixed_record_type = copy_type (fixed_record_type);
8983 TYPE_LENGTH (fixed_record_type) = size;
8984
8985 /* The FIXED_RECORD_TYPE may have be a stub. We have
8986 observed this when the debugging info is STABS, and
8987 apparently it is something that is hard to fix.
8988
8989 In practice, we don't need the actual type definition
8990 at all, because the presence of the XVZ variable allows us
8991 to assume that there must be a XVS type as well, which we
8992 should be able to use later, when we need the actual type
8993 definition.
8994
8995 In the meantime, pretend that the "fixed" type we are
8996 returning is NOT a stub, because this can cause trouble
8997 when using this type to create new types targeting it.
8998 Indeed, the associated creation routines often check
8999 whether the target type is a stub and will try to replace
0963b4bd 9000 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9001 might cause the new type to have the wrong size too.
9002 Consider the case of an array, for instance, where the size
9003 of the array is computed from the number of elements in
9004 our array multiplied by the size of its element. */
9005 TYPE_STUB (fixed_record_type) = 0;
9006 }
9007 }
1ed6ede0 9008 return fixed_record_type;
4c4b4cd2 9009 }
d2e4a39e 9010 case TYPE_CODE_ARRAY:
4c4b4cd2 9011 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9012 case TYPE_CODE_UNION:
9013 if (dval == NULL)
4c4b4cd2 9014 return type;
d2e4a39e 9015 else
4c4b4cd2 9016 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9017 }
14f9c5c9
AS
9018}
9019
f192137b
JB
9020/* The same as ada_to_fixed_type_1, except that it preserves the type
9021 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9022
9023 The typedef layer needs be preserved in order to differentiate between
9024 arrays and array pointers when both types are implemented using the same
9025 fat pointer. In the array pointer case, the pointer is encoded as
9026 a typedef of the pointer type. For instance, considering:
9027
9028 type String_Access is access String;
9029 S1 : String_Access := null;
9030
9031 To the debugger, S1 is defined as a typedef of type String. But
9032 to the user, it is a pointer. So if the user tries to print S1,
9033 we should not dereference the array, but print the array address
9034 instead.
9035
9036 If we didn't preserve the typedef layer, we would lose the fact that
9037 the type is to be presented as a pointer (needs de-reference before
9038 being printed). And we would also use the source-level type name. */
f192137b
JB
9039
9040struct type *
9041ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9042 CORE_ADDR address, struct value *dval, int check_tag)
9043
9044{
9045 struct type *fixed_type =
9046 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9047
96dbd2c1
JB
9048 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9049 then preserve the typedef layer.
9050
9051 Implementation note: We can only check the main-type portion of
9052 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9053 from TYPE now returns a type that has the same instance flags
9054 as TYPE. For instance, if TYPE is a "typedef const", and its
9055 target type is a "struct", then the typedef elimination will return
9056 a "const" version of the target type. See check_typedef for more
9057 details about how the typedef layer elimination is done.
9058
9059 brobecker/2010-11-19: It seems to me that the only case where it is
9060 useful to preserve the typedef layer is when dealing with fat pointers.
9061 Perhaps, we could add a check for that and preserve the typedef layer
9062 only in that situation. But this seems unecessary so far, probably
9063 because we call check_typedef/ada_check_typedef pretty much everywhere.
9064 */
f192137b 9065 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9066 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9067 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9068 return type;
9069
9070 return fixed_type;
9071}
9072
14f9c5c9 9073/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9074 TYPE0, but based on no runtime data. */
14f9c5c9 9075
d2e4a39e
AS
9076static struct type *
9077to_static_fixed_type (struct type *type0)
14f9c5c9 9078{
d2e4a39e 9079 struct type *type;
14f9c5c9
AS
9080
9081 if (type0 == NULL)
9082 return NULL;
9083
876cecd0 9084 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9085 return type0;
9086
61ee279c 9087 type0 = ada_check_typedef (type0);
d2e4a39e 9088
14f9c5c9
AS
9089 switch (TYPE_CODE (type0))
9090 {
9091 default:
9092 return type0;
9093 case TYPE_CODE_STRUCT:
9094 type = dynamic_template_type (type0);
d2e4a39e 9095 if (type != NULL)
4c4b4cd2
PH
9096 return template_to_static_fixed_type (type);
9097 else
9098 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9099 case TYPE_CODE_UNION:
9100 type = ada_find_parallel_type (type0, "___XVU");
9101 if (type != NULL)
4c4b4cd2
PH
9102 return template_to_static_fixed_type (type);
9103 else
9104 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9105 }
9106}
9107
4c4b4cd2
PH
9108/* A static approximation of TYPE with all type wrappers removed. */
9109
d2e4a39e
AS
9110static struct type *
9111static_unwrap_type (struct type *type)
14f9c5c9
AS
9112{
9113 if (ada_is_aligner_type (type))
9114 {
61ee279c 9115 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9116 if (ada_type_name (type1) == NULL)
4c4b4cd2 9117 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9118
9119 return static_unwrap_type (type1);
9120 }
d2e4a39e 9121 else
14f9c5c9 9122 {
d2e4a39e 9123 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9124
d2e4a39e 9125 if (raw_real_type == type)
4c4b4cd2 9126 return type;
14f9c5c9 9127 else
4c4b4cd2 9128 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9129 }
9130}
9131
9132/* In some cases, incomplete and private types require
4c4b4cd2 9133 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9134 type Foo;
9135 type FooP is access Foo;
9136 V: FooP;
9137 type Foo is array ...;
4c4b4cd2 9138 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9139 cross-references to such types, we instead substitute for FooP a
9140 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9141 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9142
9143/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9144 exists, otherwise TYPE. */
9145
d2e4a39e 9146struct type *
61ee279c 9147ada_check_typedef (struct type *type)
14f9c5c9 9148{
727e3d2e
JB
9149 if (type == NULL)
9150 return NULL;
9151
720d1a40
JB
9152 /* If our type is a typedef type of a fat pointer, then we're done.
9153 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9154 what allows us to distinguish between fat pointers that represent
9155 array types, and fat pointers that represent array access types
9156 (in both cases, the compiler implements them as fat pointers). */
9157 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9158 && is_thick_pntr (ada_typedef_target_type (type)))
9159 return type;
9160
f168693b 9161 type = check_typedef (type);
14f9c5c9 9162 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9163 || !TYPE_STUB (type)
14f9c5c9
AS
9164 || TYPE_TAG_NAME (type) == NULL)
9165 return type;
d2e4a39e 9166 else
14f9c5c9 9167 {
0d5cff50 9168 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 9169 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9170
05e522ef
JB
9171 if (type1 == NULL)
9172 return type;
9173
9174 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9175 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9176 types, only for the typedef-to-array types). If that's the case,
9177 strip the typedef layer. */
9178 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9179 type1 = ada_check_typedef (type1);
9180
9181 return type1;
14f9c5c9
AS
9182 }
9183}
9184
9185/* A value representing the data at VALADDR/ADDRESS as described by
9186 type TYPE0, but with a standard (static-sized) type that correctly
9187 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9188 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9189 creation of struct values]. */
14f9c5c9 9190
4c4b4cd2
PH
9191static struct value *
9192ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9193 struct value *val0)
14f9c5c9 9194{
1ed6ede0 9195 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9196
14f9c5c9
AS
9197 if (type == type0 && val0 != NULL)
9198 return val0;
d2e4a39e 9199 else
4c4b4cd2
PH
9200 return value_from_contents_and_address (type, 0, address);
9201}
9202
9203/* A value representing VAL, but with a standard (static-sized) type
9204 that correctly describes it. Does not necessarily create a new
9205 value. */
9206
0c3acc09 9207struct value *
4c4b4cd2
PH
9208ada_to_fixed_value (struct value *val)
9209{
c48db5ca
JB
9210 val = unwrap_value (val);
9211 val = ada_to_fixed_value_create (value_type (val),
9212 value_address (val),
9213 val);
9214 return val;
14f9c5c9 9215}
d2e4a39e 9216\f
14f9c5c9 9217
14f9c5c9
AS
9218/* Attributes */
9219
4c4b4cd2
PH
9220/* Table mapping attribute numbers to names.
9221 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9222
d2e4a39e 9223static const char *attribute_names[] = {
14f9c5c9
AS
9224 "<?>",
9225
d2e4a39e 9226 "first",
14f9c5c9
AS
9227 "last",
9228 "length",
9229 "image",
14f9c5c9
AS
9230 "max",
9231 "min",
4c4b4cd2
PH
9232 "modulus",
9233 "pos",
9234 "size",
9235 "tag",
14f9c5c9 9236 "val",
14f9c5c9
AS
9237 0
9238};
9239
d2e4a39e 9240const char *
4c4b4cd2 9241ada_attribute_name (enum exp_opcode n)
14f9c5c9 9242{
4c4b4cd2
PH
9243 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9244 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9245 else
9246 return attribute_names[0];
9247}
9248
4c4b4cd2 9249/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9250
4c4b4cd2
PH
9251static LONGEST
9252pos_atr (struct value *arg)
14f9c5c9 9253{
24209737
PH
9254 struct value *val = coerce_ref (arg);
9255 struct type *type = value_type (val);
aa715135 9256 LONGEST result;
14f9c5c9 9257
d2e4a39e 9258 if (!discrete_type_p (type))
323e0a4a 9259 error (_("'POS only defined on discrete types"));
14f9c5c9 9260
aa715135
JG
9261 if (!discrete_position (type, value_as_long (val), &result))
9262 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9263
aa715135 9264 return result;
4c4b4cd2
PH
9265}
9266
9267static struct value *
3cb382c9 9268value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9269{
3cb382c9 9270 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9271}
9272
4c4b4cd2 9273/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9274
d2e4a39e
AS
9275static struct value *
9276value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9277{
d2e4a39e 9278 if (!discrete_type_p (type))
323e0a4a 9279 error (_("'VAL only defined on discrete types"));
df407dfe 9280 if (!integer_type_p (value_type (arg)))
323e0a4a 9281 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9282
9283 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9284 {
9285 long pos = value_as_long (arg);
5b4ee69b 9286
14f9c5c9 9287 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9288 error (_("argument to 'VAL out of range"));
14e75d8e 9289 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9290 }
9291 else
9292 return value_from_longest (type, value_as_long (arg));
9293}
14f9c5c9 9294\f
d2e4a39e 9295
4c4b4cd2 9296 /* Evaluation */
14f9c5c9 9297
4c4b4cd2
PH
9298/* True if TYPE appears to be an Ada character type.
9299 [At the moment, this is true only for Character and Wide_Character;
9300 It is a heuristic test that could stand improvement]. */
14f9c5c9 9301
d2e4a39e
AS
9302int
9303ada_is_character_type (struct type *type)
14f9c5c9 9304{
7b9f71f2
JB
9305 const char *name;
9306
9307 /* If the type code says it's a character, then assume it really is,
9308 and don't check any further. */
9309 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9310 return 1;
9311
9312 /* Otherwise, assume it's a character type iff it is a discrete type
9313 with a known character type name. */
9314 name = ada_type_name (type);
9315 return (name != NULL
9316 && (TYPE_CODE (type) == TYPE_CODE_INT
9317 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9318 && (strcmp (name, "character") == 0
9319 || strcmp (name, "wide_character") == 0
5a517ebd 9320 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9321 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9322}
9323
4c4b4cd2 9324/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9325
9326int
ebf56fd3 9327ada_is_string_type (struct type *type)
14f9c5c9 9328{
61ee279c 9329 type = ada_check_typedef (type);
d2e4a39e 9330 if (type != NULL
14f9c5c9 9331 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9332 && (ada_is_simple_array_type (type)
9333 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9334 && ada_array_arity (type) == 1)
9335 {
9336 struct type *elttype = ada_array_element_type (type, 1);
9337
9338 return ada_is_character_type (elttype);
9339 }
d2e4a39e 9340 else
14f9c5c9
AS
9341 return 0;
9342}
9343
5bf03f13
JB
9344/* The compiler sometimes provides a parallel XVS type for a given
9345 PAD type. Normally, it is safe to follow the PAD type directly,
9346 but older versions of the compiler have a bug that causes the offset
9347 of its "F" field to be wrong. Following that field in that case
9348 would lead to incorrect results, but this can be worked around
9349 by ignoring the PAD type and using the associated XVS type instead.
9350
9351 Set to True if the debugger should trust the contents of PAD types.
9352 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9353static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9354
9355/* True if TYPE is a struct type introduced by the compiler to force the
9356 alignment of a value. Such types have a single field with a
4c4b4cd2 9357 distinctive name. */
14f9c5c9
AS
9358
9359int
ebf56fd3 9360ada_is_aligner_type (struct type *type)
14f9c5c9 9361{
61ee279c 9362 type = ada_check_typedef (type);
714e53ab 9363
5bf03f13 9364 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9365 return 0;
9366
14f9c5c9 9367 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9368 && TYPE_NFIELDS (type) == 1
9369 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9370}
9371
9372/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9373 the parallel type. */
14f9c5c9 9374
d2e4a39e
AS
9375struct type *
9376ada_get_base_type (struct type *raw_type)
14f9c5c9 9377{
d2e4a39e
AS
9378 struct type *real_type_namer;
9379 struct type *raw_real_type;
14f9c5c9
AS
9380
9381 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9382 return raw_type;
9383
284614f0
JB
9384 if (ada_is_aligner_type (raw_type))
9385 /* The encoding specifies that we should always use the aligner type.
9386 So, even if this aligner type has an associated XVS type, we should
9387 simply ignore it.
9388
9389 According to the compiler gurus, an XVS type parallel to an aligner
9390 type may exist because of a stabs limitation. In stabs, aligner
9391 types are empty because the field has a variable-sized type, and
9392 thus cannot actually be used as an aligner type. As a result,
9393 we need the associated parallel XVS type to decode the type.
9394 Since the policy in the compiler is to not change the internal
9395 representation based on the debugging info format, we sometimes
9396 end up having a redundant XVS type parallel to the aligner type. */
9397 return raw_type;
9398
14f9c5c9 9399 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9400 if (real_type_namer == NULL
14f9c5c9
AS
9401 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9402 || TYPE_NFIELDS (real_type_namer) != 1)
9403 return raw_type;
9404
f80d3ff2
JB
9405 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9406 {
9407 /* This is an older encoding form where the base type needs to be
9408 looked up by name. We prefer the newer enconding because it is
9409 more efficient. */
9410 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9411 if (raw_real_type == NULL)
9412 return raw_type;
9413 else
9414 return raw_real_type;
9415 }
9416
9417 /* The field in our XVS type is a reference to the base type. */
9418 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9419}
14f9c5c9 9420
4c4b4cd2 9421/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9422
d2e4a39e
AS
9423struct type *
9424ada_aligned_type (struct type *type)
14f9c5c9
AS
9425{
9426 if (ada_is_aligner_type (type))
9427 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9428 else
9429 return ada_get_base_type (type);
9430}
9431
9432
9433/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9434 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9435
fc1a4b47
AC
9436const gdb_byte *
9437ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9438{
d2e4a39e 9439 if (ada_is_aligner_type (type))
14f9c5c9 9440 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9441 valaddr +
9442 TYPE_FIELD_BITPOS (type,
9443 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9444 else
9445 return valaddr;
9446}
9447
4c4b4cd2
PH
9448
9449
14f9c5c9 9450/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9451 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9452const char *
9453ada_enum_name (const char *name)
14f9c5c9 9454{
4c4b4cd2
PH
9455 static char *result;
9456 static size_t result_len = 0;
e6a959d6 9457 const char *tmp;
14f9c5c9 9458
4c4b4cd2
PH
9459 /* First, unqualify the enumeration name:
9460 1. Search for the last '.' character. If we find one, then skip
177b42fe 9461 all the preceding characters, the unqualified name starts
76a01679 9462 right after that dot.
4c4b4cd2 9463 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9464 translates dots into "__". Search forward for double underscores,
9465 but stop searching when we hit an overloading suffix, which is
9466 of the form "__" followed by digits. */
4c4b4cd2 9467
c3e5cd34
PH
9468 tmp = strrchr (name, '.');
9469 if (tmp != NULL)
4c4b4cd2
PH
9470 name = tmp + 1;
9471 else
14f9c5c9 9472 {
4c4b4cd2
PH
9473 while ((tmp = strstr (name, "__")) != NULL)
9474 {
9475 if (isdigit (tmp[2]))
9476 break;
9477 else
9478 name = tmp + 2;
9479 }
14f9c5c9
AS
9480 }
9481
9482 if (name[0] == 'Q')
9483 {
14f9c5c9 9484 int v;
5b4ee69b 9485
14f9c5c9 9486 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9487 {
9488 if (sscanf (name + 2, "%x", &v) != 1)
9489 return name;
9490 }
14f9c5c9 9491 else
4c4b4cd2 9492 return name;
14f9c5c9 9493
4c4b4cd2 9494 GROW_VECT (result, result_len, 16);
14f9c5c9 9495 if (isascii (v) && isprint (v))
88c15c34 9496 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9497 else if (name[1] == 'U')
88c15c34 9498 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9499 else
88c15c34 9500 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9501
9502 return result;
9503 }
d2e4a39e 9504 else
4c4b4cd2 9505 {
c3e5cd34
PH
9506 tmp = strstr (name, "__");
9507 if (tmp == NULL)
9508 tmp = strstr (name, "$");
9509 if (tmp != NULL)
4c4b4cd2
PH
9510 {
9511 GROW_VECT (result, result_len, tmp - name + 1);
9512 strncpy (result, name, tmp - name);
9513 result[tmp - name] = '\0';
9514 return result;
9515 }
9516
9517 return name;
9518 }
14f9c5c9
AS
9519}
9520
14f9c5c9
AS
9521/* Evaluate the subexpression of EXP starting at *POS as for
9522 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9523 expression. */
14f9c5c9 9524
d2e4a39e
AS
9525static struct value *
9526evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9527{
4b27a620 9528 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9529}
9530
9531/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9532 value it wraps. */
14f9c5c9 9533
d2e4a39e
AS
9534static struct value *
9535unwrap_value (struct value *val)
14f9c5c9 9536{
df407dfe 9537 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9538
14f9c5c9
AS
9539 if (ada_is_aligner_type (type))
9540 {
de4d072f 9541 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9542 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9543
14f9c5c9 9544 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9545 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9546
9547 return unwrap_value (v);
9548 }
d2e4a39e 9549 else
14f9c5c9 9550 {
d2e4a39e 9551 struct type *raw_real_type =
61ee279c 9552 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9553
5bf03f13
JB
9554 /* If there is no parallel XVS or XVE type, then the value is
9555 already unwrapped. Return it without further modification. */
9556 if ((type == raw_real_type)
9557 && ada_find_parallel_type (type, "___XVE") == NULL)
9558 return val;
14f9c5c9 9559
d2e4a39e 9560 return
4c4b4cd2
PH
9561 coerce_unspec_val_to_type
9562 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9563 value_address (val),
1ed6ede0 9564 NULL, 1));
14f9c5c9
AS
9565 }
9566}
d2e4a39e
AS
9567
9568static struct value *
9569cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
9570{
9571 LONGEST val;
9572
df407dfe 9573 if (type == value_type (arg))
14f9c5c9 9574 return arg;
df407dfe 9575 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 9576 val = ada_float_to_fixed (type,
df407dfe 9577 ada_fixed_to_float (value_type (arg),
4c4b4cd2 9578 value_as_long (arg)));
d2e4a39e 9579 else
14f9c5c9 9580 {
a53b7a21 9581 DOUBLEST argd = value_as_double (arg);
5b4ee69b 9582
14f9c5c9
AS
9583 val = ada_float_to_fixed (type, argd);
9584 }
9585
9586 return value_from_longest (type, val);
9587}
9588
d2e4a39e 9589static struct value *
a53b7a21 9590cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9591{
df407dfe 9592 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 9593 value_as_long (arg));
5b4ee69b 9594
a53b7a21 9595 return value_from_double (type, val);
14f9c5c9
AS
9596}
9597
d99dcf51
JB
9598/* Given two array types T1 and T2, return nonzero iff both arrays
9599 contain the same number of elements. */
9600
9601static int
9602ada_same_array_size_p (struct type *t1, struct type *t2)
9603{
9604 LONGEST lo1, hi1, lo2, hi2;
9605
9606 /* Get the array bounds in order to verify that the size of
9607 the two arrays match. */
9608 if (!get_array_bounds (t1, &lo1, &hi1)
9609 || !get_array_bounds (t2, &lo2, &hi2))
9610 error (_("unable to determine array bounds"));
9611
9612 /* To make things easier for size comparison, normalize a bit
9613 the case of empty arrays by making sure that the difference
9614 between upper bound and lower bound is always -1. */
9615 if (lo1 > hi1)
9616 hi1 = lo1 - 1;
9617 if (lo2 > hi2)
9618 hi2 = lo2 - 1;
9619
9620 return (hi1 - lo1 == hi2 - lo2);
9621}
9622
9623/* Assuming that VAL is an array of integrals, and TYPE represents
9624 an array with the same number of elements, but with wider integral
9625 elements, return an array "casted" to TYPE. In practice, this
9626 means that the returned array is built by casting each element
9627 of the original array into TYPE's (wider) element type. */
9628
9629static struct value *
9630ada_promote_array_of_integrals (struct type *type, struct value *val)
9631{
9632 struct type *elt_type = TYPE_TARGET_TYPE (type);
9633 LONGEST lo, hi;
9634 struct value *res;
9635 LONGEST i;
9636
9637 /* Verify that both val and type are arrays of scalars, and
9638 that the size of val's elements is smaller than the size
9639 of type's element. */
9640 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9641 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9642 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9643 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9644 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9645 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9646
9647 if (!get_array_bounds (type, &lo, &hi))
9648 error (_("unable to determine array bounds"));
9649
9650 res = allocate_value (type);
9651
9652 /* Promote each array element. */
9653 for (i = 0; i < hi - lo + 1; i++)
9654 {
9655 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9656
9657 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9658 value_contents_all (elt), TYPE_LENGTH (elt_type));
9659 }
9660
9661 return res;
9662}
9663
4c4b4cd2
PH
9664/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9665 return the converted value. */
9666
d2e4a39e
AS
9667static struct value *
9668coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9669{
df407dfe 9670 struct type *type2 = value_type (val);
5b4ee69b 9671
14f9c5c9
AS
9672 if (type == type2)
9673 return val;
9674
61ee279c
PH
9675 type2 = ada_check_typedef (type2);
9676 type = ada_check_typedef (type);
14f9c5c9 9677
d2e4a39e
AS
9678 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9679 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9680 {
9681 val = ada_value_ind (val);
df407dfe 9682 type2 = value_type (val);
14f9c5c9
AS
9683 }
9684
d2e4a39e 9685 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9686 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9687 {
d99dcf51
JB
9688 if (!ada_same_array_size_p (type, type2))
9689 error (_("cannot assign arrays of different length"));
9690
9691 if (is_integral_type (TYPE_TARGET_TYPE (type))
9692 && is_integral_type (TYPE_TARGET_TYPE (type2))
9693 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9694 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9695 {
9696 /* Allow implicit promotion of the array elements to
9697 a wider type. */
9698 return ada_promote_array_of_integrals (type, val);
9699 }
9700
9701 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9702 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9703 error (_("Incompatible types in assignment"));
04624583 9704 deprecated_set_value_type (val, type);
14f9c5c9 9705 }
d2e4a39e 9706 return val;
14f9c5c9
AS
9707}
9708
4c4b4cd2
PH
9709static struct value *
9710ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9711{
9712 struct value *val;
9713 struct type *type1, *type2;
9714 LONGEST v, v1, v2;
9715
994b9211
AC
9716 arg1 = coerce_ref (arg1);
9717 arg2 = coerce_ref (arg2);
18af8284
JB
9718 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9719 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9720
76a01679
JB
9721 if (TYPE_CODE (type1) != TYPE_CODE_INT
9722 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9723 return value_binop (arg1, arg2, op);
9724
76a01679 9725 switch (op)
4c4b4cd2
PH
9726 {
9727 case BINOP_MOD:
9728 case BINOP_DIV:
9729 case BINOP_REM:
9730 break;
9731 default:
9732 return value_binop (arg1, arg2, op);
9733 }
9734
9735 v2 = value_as_long (arg2);
9736 if (v2 == 0)
323e0a4a 9737 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9738
9739 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9740 return value_binop (arg1, arg2, op);
9741
9742 v1 = value_as_long (arg1);
9743 switch (op)
9744 {
9745 case BINOP_DIV:
9746 v = v1 / v2;
76a01679
JB
9747 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9748 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9749 break;
9750 case BINOP_REM:
9751 v = v1 % v2;
76a01679
JB
9752 if (v * v1 < 0)
9753 v -= v2;
4c4b4cd2
PH
9754 break;
9755 default:
9756 /* Should not reach this point. */
9757 v = 0;
9758 }
9759
9760 val = allocate_value (type1);
990a07ab 9761 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9762 TYPE_LENGTH (value_type (val)),
9763 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9764 return val;
9765}
9766
9767static int
9768ada_value_equal (struct value *arg1, struct value *arg2)
9769{
df407dfe
AC
9770 if (ada_is_direct_array_type (value_type (arg1))
9771 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9772 {
f58b38bf
JB
9773 /* Automatically dereference any array reference before
9774 we attempt to perform the comparison. */
9775 arg1 = ada_coerce_ref (arg1);
9776 arg2 = ada_coerce_ref (arg2);
9777
4c4b4cd2
PH
9778 arg1 = ada_coerce_to_simple_array (arg1);
9779 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9780 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9781 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9782 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9783 /* FIXME: The following works only for types whose
76a01679
JB
9784 representations use all bits (no padding or undefined bits)
9785 and do not have user-defined equality. */
9786 return
df407dfe 9787 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9788 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9789 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9790 }
9791 return value_equal (arg1, arg2);
9792}
9793
52ce6436
PH
9794/* Total number of component associations in the aggregate starting at
9795 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9796 OP_AGGREGATE. */
52ce6436
PH
9797
9798static int
9799num_component_specs (struct expression *exp, int pc)
9800{
9801 int n, m, i;
5b4ee69b 9802
52ce6436
PH
9803 m = exp->elts[pc + 1].longconst;
9804 pc += 3;
9805 n = 0;
9806 for (i = 0; i < m; i += 1)
9807 {
9808 switch (exp->elts[pc].opcode)
9809 {
9810 default:
9811 n += 1;
9812 break;
9813 case OP_CHOICES:
9814 n += exp->elts[pc + 1].longconst;
9815 break;
9816 }
9817 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9818 }
9819 return n;
9820}
9821
9822/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9823 component of LHS (a simple array or a record), updating *POS past
9824 the expression, assuming that LHS is contained in CONTAINER. Does
9825 not modify the inferior's memory, nor does it modify LHS (unless
9826 LHS == CONTAINER). */
9827
9828static void
9829assign_component (struct value *container, struct value *lhs, LONGEST index,
9830 struct expression *exp, int *pos)
9831{
9832 struct value *mark = value_mark ();
9833 struct value *elt;
5b4ee69b 9834
52ce6436
PH
9835 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9836 {
22601c15
UW
9837 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9838 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9839
52ce6436
PH
9840 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9841 }
9842 else
9843 {
9844 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9845 elt = ada_to_fixed_value (elt);
52ce6436
PH
9846 }
9847
9848 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9849 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9850 else
9851 value_assign_to_component (container, elt,
9852 ada_evaluate_subexp (NULL, exp, pos,
9853 EVAL_NORMAL));
9854
9855 value_free_to_mark (mark);
9856}
9857
9858/* Assuming that LHS represents an lvalue having a record or array
9859 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9860 of that aggregate's value to LHS, advancing *POS past the
9861 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9862 lvalue containing LHS (possibly LHS itself). Does not modify
9863 the inferior's memory, nor does it modify the contents of
0963b4bd 9864 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9865
9866static struct value *
9867assign_aggregate (struct value *container,
9868 struct value *lhs, struct expression *exp,
9869 int *pos, enum noside noside)
9870{
9871 struct type *lhs_type;
9872 int n = exp->elts[*pos+1].longconst;
9873 LONGEST low_index, high_index;
9874 int num_specs;
9875 LONGEST *indices;
9876 int max_indices, num_indices;
52ce6436 9877 int i;
52ce6436
PH
9878
9879 *pos += 3;
9880 if (noside != EVAL_NORMAL)
9881 {
52ce6436
PH
9882 for (i = 0; i < n; i += 1)
9883 ada_evaluate_subexp (NULL, exp, pos, noside);
9884 return container;
9885 }
9886
9887 container = ada_coerce_ref (container);
9888 if (ada_is_direct_array_type (value_type (container)))
9889 container = ada_coerce_to_simple_array (container);
9890 lhs = ada_coerce_ref (lhs);
9891 if (!deprecated_value_modifiable (lhs))
9892 error (_("Left operand of assignment is not a modifiable lvalue."));
9893
9894 lhs_type = value_type (lhs);
9895 if (ada_is_direct_array_type (lhs_type))
9896 {
9897 lhs = ada_coerce_to_simple_array (lhs);
9898 lhs_type = value_type (lhs);
9899 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9900 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9901 }
9902 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9903 {
9904 low_index = 0;
9905 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9906 }
9907 else
9908 error (_("Left-hand side must be array or record."));
9909
9910 num_specs = num_component_specs (exp, *pos - 3);
9911 max_indices = 4 * num_specs + 4;
8d749320 9912 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
9913 indices[0] = indices[1] = low_index - 1;
9914 indices[2] = indices[3] = high_index + 1;
9915 num_indices = 4;
9916
9917 for (i = 0; i < n; i += 1)
9918 {
9919 switch (exp->elts[*pos].opcode)
9920 {
1fbf5ada
JB
9921 case OP_CHOICES:
9922 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9923 &num_indices, max_indices,
9924 low_index, high_index);
9925 break;
9926 case OP_POSITIONAL:
9927 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9928 &num_indices, max_indices,
9929 low_index, high_index);
1fbf5ada
JB
9930 break;
9931 case OP_OTHERS:
9932 if (i != n-1)
9933 error (_("Misplaced 'others' clause"));
9934 aggregate_assign_others (container, lhs, exp, pos, indices,
9935 num_indices, low_index, high_index);
9936 break;
9937 default:
9938 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9939 }
9940 }
9941
9942 return container;
9943}
9944
9945/* Assign into the component of LHS indexed by the OP_POSITIONAL
9946 construct at *POS, updating *POS past the construct, given that
9947 the positions are relative to lower bound LOW, where HIGH is the
9948 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9949 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9950 assign_aggregate. */
52ce6436
PH
9951static void
9952aggregate_assign_positional (struct value *container,
9953 struct value *lhs, struct expression *exp,
9954 int *pos, LONGEST *indices, int *num_indices,
9955 int max_indices, LONGEST low, LONGEST high)
9956{
9957 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9958
9959 if (ind - 1 == high)
e1d5a0d2 9960 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9961 if (ind <= high)
9962 {
9963 add_component_interval (ind, ind, indices, num_indices, max_indices);
9964 *pos += 3;
9965 assign_component (container, lhs, ind, exp, pos);
9966 }
9967 else
9968 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9969}
9970
9971/* Assign into the components of LHS indexed by the OP_CHOICES
9972 construct at *POS, updating *POS past the construct, given that
9973 the allowable indices are LOW..HIGH. Record the indices assigned
9974 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9975 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9976static void
9977aggregate_assign_from_choices (struct value *container,
9978 struct value *lhs, struct expression *exp,
9979 int *pos, LONGEST *indices, int *num_indices,
9980 int max_indices, LONGEST low, LONGEST high)
9981{
9982 int j;
9983 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9984 int choice_pos, expr_pc;
9985 int is_array = ada_is_direct_array_type (value_type (lhs));
9986
9987 choice_pos = *pos += 3;
9988
9989 for (j = 0; j < n_choices; j += 1)
9990 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9991 expr_pc = *pos;
9992 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9993
9994 for (j = 0; j < n_choices; j += 1)
9995 {
9996 LONGEST lower, upper;
9997 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9998
52ce6436
PH
9999 if (op == OP_DISCRETE_RANGE)
10000 {
10001 choice_pos += 1;
10002 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10003 EVAL_NORMAL));
10004 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10005 EVAL_NORMAL));
10006 }
10007 else if (is_array)
10008 {
10009 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10010 EVAL_NORMAL));
10011 upper = lower;
10012 }
10013 else
10014 {
10015 int ind;
0d5cff50 10016 const char *name;
5b4ee69b 10017
52ce6436
PH
10018 switch (op)
10019 {
10020 case OP_NAME:
10021 name = &exp->elts[choice_pos + 2].string;
10022 break;
10023 case OP_VAR_VALUE:
10024 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10025 break;
10026 default:
10027 error (_("Invalid record component association."));
10028 }
10029 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10030 ind = 0;
10031 if (! find_struct_field (name, value_type (lhs), 0,
10032 NULL, NULL, NULL, NULL, &ind))
10033 error (_("Unknown component name: %s."), name);
10034 lower = upper = ind;
10035 }
10036
10037 if (lower <= upper && (lower < low || upper > high))
10038 error (_("Index in component association out of bounds."));
10039
10040 add_component_interval (lower, upper, indices, num_indices,
10041 max_indices);
10042 while (lower <= upper)
10043 {
10044 int pos1;
5b4ee69b 10045
52ce6436
PH
10046 pos1 = expr_pc;
10047 assign_component (container, lhs, lower, exp, &pos1);
10048 lower += 1;
10049 }
10050 }
10051}
10052
10053/* Assign the value of the expression in the OP_OTHERS construct in
10054 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10055 have not been previously assigned. The index intervals already assigned
10056 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10057 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10058static void
10059aggregate_assign_others (struct value *container,
10060 struct value *lhs, struct expression *exp,
10061 int *pos, LONGEST *indices, int num_indices,
10062 LONGEST low, LONGEST high)
10063{
10064 int i;
5ce64950 10065 int expr_pc = *pos + 1;
52ce6436
PH
10066
10067 for (i = 0; i < num_indices - 2; i += 2)
10068 {
10069 LONGEST ind;
5b4ee69b 10070
52ce6436
PH
10071 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10072 {
5ce64950 10073 int localpos;
5b4ee69b 10074
5ce64950
MS
10075 localpos = expr_pc;
10076 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10077 }
10078 }
10079 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10080}
10081
10082/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10083 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10084 modifying *SIZE as needed. It is an error if *SIZE exceeds
10085 MAX_SIZE. The resulting intervals do not overlap. */
10086static void
10087add_component_interval (LONGEST low, LONGEST high,
10088 LONGEST* indices, int *size, int max_size)
10089{
10090 int i, j;
5b4ee69b 10091
52ce6436
PH
10092 for (i = 0; i < *size; i += 2) {
10093 if (high >= indices[i] && low <= indices[i + 1])
10094 {
10095 int kh;
5b4ee69b 10096
52ce6436
PH
10097 for (kh = i + 2; kh < *size; kh += 2)
10098 if (high < indices[kh])
10099 break;
10100 if (low < indices[i])
10101 indices[i] = low;
10102 indices[i + 1] = indices[kh - 1];
10103 if (high > indices[i + 1])
10104 indices[i + 1] = high;
10105 memcpy (indices + i + 2, indices + kh, *size - kh);
10106 *size -= kh - i - 2;
10107 return;
10108 }
10109 else if (high < indices[i])
10110 break;
10111 }
10112
10113 if (*size == max_size)
10114 error (_("Internal error: miscounted aggregate components."));
10115 *size += 2;
10116 for (j = *size-1; j >= i+2; j -= 1)
10117 indices[j] = indices[j - 2];
10118 indices[i] = low;
10119 indices[i + 1] = high;
10120}
10121
6e48bd2c
JB
10122/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10123 is different. */
10124
10125static struct value *
10126ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
10127{
10128 if (type == ada_check_typedef (value_type (arg2)))
10129 return arg2;
10130
10131 if (ada_is_fixed_point_type (type))
10132 return (cast_to_fixed (type, arg2));
10133
10134 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10135 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10136
10137 return value_cast (type, arg2);
10138}
10139
284614f0
JB
10140/* Evaluating Ada expressions, and printing their result.
10141 ------------------------------------------------------
10142
21649b50
JB
10143 1. Introduction:
10144 ----------------
10145
284614f0
JB
10146 We usually evaluate an Ada expression in order to print its value.
10147 We also evaluate an expression in order to print its type, which
10148 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10149 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10150 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10151 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10152 similar.
10153
10154 Evaluating expressions is a little more complicated for Ada entities
10155 than it is for entities in languages such as C. The main reason for
10156 this is that Ada provides types whose definition might be dynamic.
10157 One example of such types is variant records. Or another example
10158 would be an array whose bounds can only be known at run time.
10159
10160 The following description is a general guide as to what should be
10161 done (and what should NOT be done) in order to evaluate an expression
10162 involving such types, and when. This does not cover how the semantic
10163 information is encoded by GNAT as this is covered separatly. For the
10164 document used as the reference for the GNAT encoding, see exp_dbug.ads
10165 in the GNAT sources.
10166
10167 Ideally, we should embed each part of this description next to its
10168 associated code. Unfortunately, the amount of code is so vast right
10169 now that it's hard to see whether the code handling a particular
10170 situation might be duplicated or not. One day, when the code is
10171 cleaned up, this guide might become redundant with the comments
10172 inserted in the code, and we might want to remove it.
10173
21649b50
JB
10174 2. ``Fixing'' an Entity, the Simple Case:
10175 -----------------------------------------
10176
284614f0
JB
10177 When evaluating Ada expressions, the tricky issue is that they may
10178 reference entities whose type contents and size are not statically
10179 known. Consider for instance a variant record:
10180
10181 type Rec (Empty : Boolean := True) is record
10182 case Empty is
10183 when True => null;
10184 when False => Value : Integer;
10185 end case;
10186 end record;
10187 Yes : Rec := (Empty => False, Value => 1);
10188 No : Rec := (empty => True);
10189
10190 The size and contents of that record depends on the value of the
10191 descriminant (Rec.Empty). At this point, neither the debugging
10192 information nor the associated type structure in GDB are able to
10193 express such dynamic types. So what the debugger does is to create
10194 "fixed" versions of the type that applies to the specific object.
10195 We also informally refer to this opperation as "fixing" an object,
10196 which means creating its associated fixed type.
10197
10198 Example: when printing the value of variable "Yes" above, its fixed
10199 type would look like this:
10200
10201 type Rec is record
10202 Empty : Boolean;
10203 Value : Integer;
10204 end record;
10205
10206 On the other hand, if we printed the value of "No", its fixed type
10207 would become:
10208
10209 type Rec is record
10210 Empty : Boolean;
10211 end record;
10212
10213 Things become a little more complicated when trying to fix an entity
10214 with a dynamic type that directly contains another dynamic type,
10215 such as an array of variant records, for instance. There are
10216 two possible cases: Arrays, and records.
10217
21649b50
JB
10218 3. ``Fixing'' Arrays:
10219 ---------------------
10220
10221 The type structure in GDB describes an array in terms of its bounds,
10222 and the type of its elements. By design, all elements in the array
10223 have the same type and we cannot represent an array of variant elements
10224 using the current type structure in GDB. When fixing an array,
10225 we cannot fix the array element, as we would potentially need one
10226 fixed type per element of the array. As a result, the best we can do
10227 when fixing an array is to produce an array whose bounds and size
10228 are correct (allowing us to read it from memory), but without having
10229 touched its element type. Fixing each element will be done later,
10230 when (if) necessary.
10231
10232 Arrays are a little simpler to handle than records, because the same
10233 amount of memory is allocated for each element of the array, even if
1b536f04 10234 the amount of space actually used by each element differs from element
21649b50 10235 to element. Consider for instance the following array of type Rec:
284614f0
JB
10236
10237 type Rec_Array is array (1 .. 2) of Rec;
10238
1b536f04
JB
10239 The actual amount of memory occupied by each element might be different
10240 from element to element, depending on the value of their discriminant.
21649b50 10241 But the amount of space reserved for each element in the array remains
1b536f04 10242 fixed regardless. So we simply need to compute that size using
21649b50
JB
10243 the debugging information available, from which we can then determine
10244 the array size (we multiply the number of elements of the array by
10245 the size of each element).
10246
10247 The simplest case is when we have an array of a constrained element
10248 type. For instance, consider the following type declarations:
10249
10250 type Bounded_String (Max_Size : Integer) is
10251 Length : Integer;
10252 Buffer : String (1 .. Max_Size);
10253 end record;
10254 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10255
10256 In this case, the compiler describes the array as an array of
10257 variable-size elements (identified by its XVS suffix) for which
10258 the size can be read in the parallel XVZ variable.
10259
10260 In the case of an array of an unconstrained element type, the compiler
10261 wraps the array element inside a private PAD type. This type should not
10262 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10263 that we also use the adjective "aligner" in our code to designate
10264 these wrapper types.
10265
1b536f04 10266 In some cases, the size allocated for each element is statically
21649b50
JB
10267 known. In that case, the PAD type already has the correct size,
10268 and the array element should remain unfixed.
10269
10270 But there are cases when this size is not statically known.
10271 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10272
10273 type Dynamic is array (1 .. Five) of Integer;
10274 type Wrapper (Has_Length : Boolean := False) is record
10275 Data : Dynamic;
10276 case Has_Length is
10277 when True => Length : Integer;
10278 when False => null;
10279 end case;
10280 end record;
10281 type Wrapper_Array is array (1 .. 2) of Wrapper;
10282
10283 Hello : Wrapper_Array := (others => (Has_Length => True,
10284 Data => (others => 17),
10285 Length => 1));
10286
10287
10288 The debugging info would describe variable Hello as being an
10289 array of a PAD type. The size of that PAD type is not statically
10290 known, but can be determined using a parallel XVZ variable.
10291 In that case, a copy of the PAD type with the correct size should
10292 be used for the fixed array.
10293
21649b50
JB
10294 3. ``Fixing'' record type objects:
10295 ----------------------------------
10296
10297 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10298 record types. In this case, in order to compute the associated
10299 fixed type, we need to determine the size and offset of each of
10300 its components. This, in turn, requires us to compute the fixed
10301 type of each of these components.
10302
10303 Consider for instance the example:
10304
10305 type Bounded_String (Max_Size : Natural) is record
10306 Str : String (1 .. Max_Size);
10307 Length : Natural;
10308 end record;
10309 My_String : Bounded_String (Max_Size => 10);
10310
10311 In that case, the position of field "Length" depends on the size
10312 of field Str, which itself depends on the value of the Max_Size
21649b50 10313 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10314 we need to fix the type of field Str. Therefore, fixing a variant
10315 record requires us to fix each of its components.
10316
10317 However, if a component does not have a dynamic size, the component
10318 should not be fixed. In particular, fields that use a PAD type
10319 should not fixed. Here is an example where this might happen
10320 (assuming type Rec above):
10321
10322 type Container (Big : Boolean) is record
10323 First : Rec;
10324 After : Integer;
10325 case Big is
10326 when True => Another : Integer;
10327 when False => null;
10328 end case;
10329 end record;
10330 My_Container : Container := (Big => False,
10331 First => (Empty => True),
10332 After => 42);
10333
10334 In that example, the compiler creates a PAD type for component First,
10335 whose size is constant, and then positions the component After just
10336 right after it. The offset of component After is therefore constant
10337 in this case.
10338
10339 The debugger computes the position of each field based on an algorithm
10340 that uses, among other things, the actual position and size of the field
21649b50
JB
10341 preceding it. Let's now imagine that the user is trying to print
10342 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10343 end up computing the offset of field After based on the size of the
10344 fixed version of field First. And since in our example First has
10345 only one actual field, the size of the fixed type is actually smaller
10346 than the amount of space allocated to that field, and thus we would
10347 compute the wrong offset of field After.
10348
21649b50
JB
10349 To make things more complicated, we need to watch out for dynamic
10350 components of variant records (identified by the ___XVL suffix in
10351 the component name). Even if the target type is a PAD type, the size
10352 of that type might not be statically known. So the PAD type needs
10353 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10354 we might end up with the wrong size for our component. This can be
10355 observed with the following type declarations:
284614f0
JB
10356
10357 type Octal is new Integer range 0 .. 7;
10358 type Octal_Array is array (Positive range <>) of Octal;
10359 pragma Pack (Octal_Array);
10360
10361 type Octal_Buffer (Size : Positive) is record
10362 Buffer : Octal_Array (1 .. Size);
10363 Length : Integer;
10364 end record;
10365
10366 In that case, Buffer is a PAD type whose size is unset and needs
10367 to be computed by fixing the unwrapped type.
10368
21649b50
JB
10369 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10370 ----------------------------------------------------------
10371
10372 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10373 thus far, be actually fixed?
10374
10375 The answer is: Only when referencing that element. For instance
10376 when selecting one component of a record, this specific component
10377 should be fixed at that point in time. Or when printing the value
10378 of a record, each component should be fixed before its value gets
10379 printed. Similarly for arrays, the element of the array should be
10380 fixed when printing each element of the array, or when extracting
10381 one element out of that array. On the other hand, fixing should
10382 not be performed on the elements when taking a slice of an array!
10383
10384 Note that one of the side-effects of miscomputing the offset and
10385 size of each field is that we end up also miscomputing the size
10386 of the containing type. This can have adverse results when computing
10387 the value of an entity. GDB fetches the value of an entity based
10388 on the size of its type, and thus a wrong size causes GDB to fetch
10389 the wrong amount of memory. In the case where the computed size is
10390 too small, GDB fetches too little data to print the value of our
10391 entiry. Results in this case as unpredicatble, as we usually read
10392 past the buffer containing the data =:-o. */
10393
10394/* Implement the evaluate_exp routine in the exp_descriptor structure
10395 for the Ada language. */
10396
52ce6436 10397static struct value *
ebf56fd3 10398ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10399 int *pos, enum noside noside)
14f9c5c9
AS
10400{
10401 enum exp_opcode op;
b5385fc0 10402 int tem;
14f9c5c9 10403 int pc;
5ec18f2b 10404 int preeval_pos;
14f9c5c9
AS
10405 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10406 struct type *type;
52ce6436 10407 int nargs, oplen;
d2e4a39e 10408 struct value **argvec;
14f9c5c9 10409
d2e4a39e
AS
10410 pc = *pos;
10411 *pos += 1;
14f9c5c9
AS
10412 op = exp->elts[pc].opcode;
10413
d2e4a39e 10414 switch (op)
14f9c5c9
AS
10415 {
10416 default:
10417 *pos -= 1;
6e48bd2c 10418 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10419
10420 if (noside == EVAL_NORMAL)
10421 arg1 = unwrap_value (arg1);
6e48bd2c
JB
10422
10423 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
10424 then we need to perform the conversion manually, because
10425 evaluate_subexp_standard doesn't do it. This conversion is
10426 necessary in Ada because the different kinds of float/fixed
10427 types in Ada have different representations.
10428
10429 Similarly, we need to perform the conversion from OP_LONG
10430 ourselves. */
10431 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
10432 arg1 = ada_value_cast (expect_type, arg1, noside);
10433
10434 return arg1;
4c4b4cd2
PH
10435
10436 case OP_STRING:
10437 {
76a01679 10438 struct value *result;
5b4ee69b 10439
76a01679
JB
10440 *pos -= 1;
10441 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10442 /* The result type will have code OP_STRING, bashed there from
10443 OP_ARRAY. Bash it back. */
df407dfe
AC
10444 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10445 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10446 return result;
4c4b4cd2 10447 }
14f9c5c9
AS
10448
10449 case UNOP_CAST:
10450 (*pos) += 2;
10451 type = exp->elts[pc + 1].type;
10452 arg1 = evaluate_subexp (type, exp, pos, noside);
10453 if (noside == EVAL_SKIP)
4c4b4cd2 10454 goto nosideret;
6e48bd2c 10455 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
10456 return arg1;
10457
4c4b4cd2
PH
10458 case UNOP_QUAL:
10459 (*pos) += 2;
10460 type = exp->elts[pc + 1].type;
10461 return ada_evaluate_subexp (type, exp, pos, noside);
10462
14f9c5c9
AS
10463 case BINOP_ASSIGN:
10464 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10465 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10466 {
10467 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10468 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10469 return arg1;
10470 return ada_value_assign (arg1, arg1);
10471 }
003f3813
JB
10472 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10473 except if the lhs of our assignment is a convenience variable.
10474 In the case of assigning to a convenience variable, the lhs
10475 should be exactly the result of the evaluation of the rhs. */
10476 type = value_type (arg1);
10477 if (VALUE_LVAL (arg1) == lval_internalvar)
10478 type = NULL;
10479 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10480 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10481 return arg1;
df407dfe
AC
10482 if (ada_is_fixed_point_type (value_type (arg1)))
10483 arg2 = cast_to_fixed (value_type (arg1), arg2);
10484 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10485 error
323e0a4a 10486 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10487 else
df407dfe 10488 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10489 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10490
10491 case BINOP_ADD:
10492 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10493 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10494 if (noside == EVAL_SKIP)
4c4b4cd2 10495 goto nosideret;
2ac8a782
JB
10496 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10497 return (value_from_longest
10498 (value_type (arg1),
10499 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10500 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10501 return (value_from_longest
10502 (value_type (arg2),
10503 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10504 if ((ada_is_fixed_point_type (value_type (arg1))
10505 || ada_is_fixed_point_type (value_type (arg2)))
10506 && value_type (arg1) != value_type (arg2))
323e0a4a 10507 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10508 /* Do the addition, and cast the result to the type of the first
10509 argument. We cannot cast the result to a reference type, so if
10510 ARG1 is a reference type, find its underlying type. */
10511 type = value_type (arg1);
10512 while (TYPE_CODE (type) == TYPE_CODE_REF)
10513 type = TYPE_TARGET_TYPE (type);
f44316fa 10514 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10515 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10516
10517 case BINOP_SUB:
10518 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10519 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10520 if (noside == EVAL_SKIP)
4c4b4cd2 10521 goto nosideret;
2ac8a782
JB
10522 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10523 return (value_from_longest
10524 (value_type (arg1),
10525 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10526 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10527 return (value_from_longest
10528 (value_type (arg2),
10529 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10530 if ((ada_is_fixed_point_type (value_type (arg1))
10531 || ada_is_fixed_point_type (value_type (arg2)))
10532 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10533 error (_("Operands of fixed-point subtraction "
10534 "must have the same type"));
b7789565
JB
10535 /* Do the substraction, and cast the result to the type of the first
10536 argument. We cannot cast the result to a reference type, so if
10537 ARG1 is a reference type, find its underlying type. */
10538 type = value_type (arg1);
10539 while (TYPE_CODE (type) == TYPE_CODE_REF)
10540 type = TYPE_TARGET_TYPE (type);
f44316fa 10541 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10542 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10543
10544 case BINOP_MUL:
10545 case BINOP_DIV:
e1578042
JB
10546 case BINOP_REM:
10547 case BINOP_MOD:
14f9c5c9
AS
10548 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10549 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10550 if (noside == EVAL_SKIP)
4c4b4cd2 10551 goto nosideret;
e1578042 10552 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10553 {
10554 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10555 return value_zero (value_type (arg1), not_lval);
10556 }
14f9c5c9 10557 else
4c4b4cd2 10558 {
a53b7a21 10559 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10560 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10561 arg1 = cast_from_fixed (type, arg1);
df407dfe 10562 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10563 arg2 = cast_from_fixed (type, arg2);
f44316fa 10564 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10565 return ada_value_binop (arg1, arg2, op);
10566 }
10567
4c4b4cd2
PH
10568 case BINOP_EQUAL:
10569 case BINOP_NOTEQUAL:
14f9c5c9 10570 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10571 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10572 if (noside == EVAL_SKIP)
76a01679 10573 goto nosideret;
4c4b4cd2 10574 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10575 tem = 0;
4c4b4cd2 10576 else
f44316fa
UW
10577 {
10578 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10579 tem = ada_value_equal (arg1, arg2);
10580 }
4c4b4cd2 10581 if (op == BINOP_NOTEQUAL)
76a01679 10582 tem = !tem;
fbb06eb1
UW
10583 type = language_bool_type (exp->language_defn, exp->gdbarch);
10584 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10585
10586 case UNOP_NEG:
10587 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10588 if (noside == EVAL_SKIP)
10589 goto nosideret;
df407dfe
AC
10590 else if (ada_is_fixed_point_type (value_type (arg1)))
10591 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10592 else
f44316fa
UW
10593 {
10594 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10595 return value_neg (arg1);
10596 }
4c4b4cd2 10597
2330c6c6
JB
10598 case BINOP_LOGICAL_AND:
10599 case BINOP_LOGICAL_OR:
10600 case UNOP_LOGICAL_NOT:
000d5124
JB
10601 {
10602 struct value *val;
10603
10604 *pos -= 1;
10605 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10606 type = language_bool_type (exp->language_defn, exp->gdbarch);
10607 return value_cast (type, val);
000d5124 10608 }
2330c6c6
JB
10609
10610 case BINOP_BITWISE_AND:
10611 case BINOP_BITWISE_IOR:
10612 case BINOP_BITWISE_XOR:
000d5124
JB
10613 {
10614 struct value *val;
10615
10616 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10617 *pos = pc;
10618 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10619
10620 return value_cast (value_type (arg1), val);
10621 }
2330c6c6 10622
14f9c5c9
AS
10623 case OP_VAR_VALUE:
10624 *pos -= 1;
6799def4 10625
14f9c5c9 10626 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10627 {
10628 *pos += 4;
10629 goto nosideret;
10630 }
da5c522f
JB
10631
10632 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10633 /* Only encountered when an unresolved symbol occurs in a
10634 context other than a function call, in which case, it is
52ce6436 10635 invalid. */
323e0a4a 10636 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10637 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10638
10639 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10640 {
0c1f74cf 10641 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10642 /* Check to see if this is a tagged type. We also need to handle
10643 the case where the type is a reference to a tagged type, but
10644 we have to be careful to exclude pointers to tagged types.
10645 The latter should be shown as usual (as a pointer), whereas
10646 a reference should mostly be transparent to the user. */
10647 if (ada_is_tagged_type (type, 0)
023db19c 10648 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10649 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10650 {
10651 /* Tagged types are a little special in the fact that the real
10652 type is dynamic and can only be determined by inspecting the
10653 object's tag. This means that we need to get the object's
10654 value first (EVAL_NORMAL) and then extract the actual object
10655 type from its tag.
10656
10657 Note that we cannot skip the final step where we extract
10658 the object type from its tag, because the EVAL_NORMAL phase
10659 results in dynamic components being resolved into fixed ones.
10660 This can cause problems when trying to print the type
10661 description of tagged types whose parent has a dynamic size:
10662 We use the type name of the "_parent" component in order
10663 to print the name of the ancestor type in the type description.
10664 If that component had a dynamic size, the resolution into
10665 a fixed type would result in the loss of that type name,
10666 thus preventing us from printing the name of the ancestor
10667 type in the type description. */
10668 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10669
10670 if (TYPE_CODE (type) != TYPE_CODE_REF)
10671 {
10672 struct type *actual_type;
10673
10674 actual_type = type_from_tag (ada_value_tag (arg1));
10675 if (actual_type == NULL)
10676 /* If, for some reason, we were unable to determine
10677 the actual type from the tag, then use the static
10678 approximation that we just computed as a fallback.
10679 This can happen if the debugging information is
10680 incomplete, for instance. */
10681 actual_type = type;
10682 return value_zero (actual_type, not_lval);
10683 }
10684 else
10685 {
10686 /* In the case of a ref, ada_coerce_ref takes care
10687 of determining the actual type. But the evaluation
10688 should return a ref as it should be valid to ask
10689 for its address; so rebuild a ref after coerce. */
10690 arg1 = ada_coerce_ref (arg1);
a65cfae5 10691 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10692 }
10693 }
0c1f74cf 10694
84754697
JB
10695 /* Records and unions for which GNAT encodings have been
10696 generated need to be statically fixed as well.
10697 Otherwise, non-static fixing produces a type where
10698 all dynamic properties are removed, which prevents "ptype"
10699 from being able to completely describe the type.
10700 For instance, a case statement in a variant record would be
10701 replaced by the relevant components based on the actual
10702 value of the discriminants. */
10703 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10704 && dynamic_template_type (type) != NULL)
10705 || (TYPE_CODE (type) == TYPE_CODE_UNION
10706 && ada_find_parallel_type (type, "___XVU") != NULL))
10707 {
10708 *pos += 4;
10709 return value_zero (to_static_fixed_type (type), not_lval);
10710 }
4c4b4cd2 10711 }
da5c522f
JB
10712
10713 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10714 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10715
10716 case OP_FUNCALL:
10717 (*pos) += 2;
10718
10719 /* Allocate arg vector, including space for the function to be
10720 called in argvec[0] and a terminating NULL. */
10721 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10722 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10723
10724 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10725 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10726 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10727 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10728 else
10729 {
10730 for (tem = 0; tem <= nargs; tem += 1)
10731 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10732 argvec[tem] = 0;
10733
10734 if (noside == EVAL_SKIP)
10735 goto nosideret;
10736 }
10737
ad82864c
JB
10738 if (ada_is_constrained_packed_array_type
10739 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10740 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10741 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10742 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10743 /* This is a packed array that has already been fixed, and
10744 therefore already coerced to a simple array. Nothing further
10745 to do. */
10746 ;
e6c2c623
PMR
10747 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10748 {
10749 /* Make sure we dereference references so that all the code below
10750 feels like it's really handling the referenced value. Wrapping
10751 types (for alignment) may be there, so make sure we strip them as
10752 well. */
10753 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10754 }
10755 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10756 && VALUE_LVAL (argvec[0]) == lval_memory)
10757 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10758
df407dfe 10759 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10760
10761 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10762 them. So, if this is an array typedef (encoding use for array
10763 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10764 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10765 type = ada_typedef_target_type (type);
10766
4c4b4cd2
PH
10767 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10768 {
61ee279c 10769 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10770 {
10771 case TYPE_CODE_FUNC:
61ee279c 10772 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10773 break;
10774 case TYPE_CODE_ARRAY:
10775 break;
10776 case TYPE_CODE_STRUCT:
10777 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10778 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10779 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10780 break;
10781 default:
323e0a4a 10782 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10783 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10784 break;
10785 }
10786 }
10787
10788 switch (TYPE_CODE (type))
10789 {
10790 case TYPE_CODE_FUNC:
10791 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972 10792 {
7022349d
PA
10793 if (TYPE_TARGET_TYPE (type) == NULL)
10794 error_call_unknown_return_type (NULL);
10795 return allocate_value (TYPE_TARGET_TYPE (type));
c8ea1972 10796 }
7022349d 10797 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
c8ea1972
PH
10798 case TYPE_CODE_INTERNAL_FUNCTION:
10799 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10800 /* We don't know anything about what the internal
10801 function might return, but we have to return
10802 something. */
10803 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10804 not_lval);
10805 else
10806 return call_internal_function (exp->gdbarch, exp->language_defn,
10807 argvec[0], nargs, argvec + 1);
10808
4c4b4cd2
PH
10809 case TYPE_CODE_STRUCT:
10810 {
10811 int arity;
10812
4c4b4cd2
PH
10813 arity = ada_array_arity (type);
10814 type = ada_array_element_type (type, nargs);
10815 if (type == NULL)
323e0a4a 10816 error (_("cannot subscript or call a record"));
4c4b4cd2 10817 if (arity != nargs)
323e0a4a 10818 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10819 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10820 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10821 return
10822 unwrap_value (ada_value_subscript
10823 (argvec[0], nargs, argvec + 1));
10824 }
10825 case TYPE_CODE_ARRAY:
10826 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10827 {
10828 type = ada_array_element_type (type, nargs);
10829 if (type == NULL)
323e0a4a 10830 error (_("element type of array unknown"));
4c4b4cd2 10831 else
0a07e705 10832 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10833 }
10834 return
10835 unwrap_value (ada_value_subscript
10836 (ada_coerce_to_simple_array (argvec[0]),
10837 nargs, argvec + 1));
10838 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10839 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10840 {
deede10c 10841 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10842 type = ada_array_element_type (type, nargs);
10843 if (type == NULL)
323e0a4a 10844 error (_("element type of array unknown"));
4c4b4cd2 10845 else
0a07e705 10846 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10847 }
10848 return
deede10c
JB
10849 unwrap_value (ada_value_ptr_subscript (argvec[0],
10850 nargs, argvec + 1));
4c4b4cd2
PH
10851
10852 default:
e1d5a0d2
PH
10853 error (_("Attempt to index or call something other than an "
10854 "array or function"));
4c4b4cd2
PH
10855 }
10856
10857 case TERNOP_SLICE:
10858 {
10859 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10860 struct value *low_bound_val =
10861 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10862 struct value *high_bound_val =
10863 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10864 LONGEST low_bound;
10865 LONGEST high_bound;
5b4ee69b 10866
994b9211
AC
10867 low_bound_val = coerce_ref (low_bound_val);
10868 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
10869 low_bound = value_as_long (low_bound_val);
10870 high_bound = value_as_long (high_bound_val);
963a6417 10871
4c4b4cd2
PH
10872 if (noside == EVAL_SKIP)
10873 goto nosideret;
10874
4c4b4cd2
PH
10875 /* If this is a reference to an aligner type, then remove all
10876 the aligners. */
df407dfe
AC
10877 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10878 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10879 TYPE_TARGET_TYPE (value_type (array)) =
10880 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10881
ad82864c 10882 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10883 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10884
10885 /* If this is a reference to an array or an array lvalue,
10886 convert to a pointer. */
df407dfe
AC
10887 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10888 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10889 && VALUE_LVAL (array) == lval_memory))
10890 array = value_addr (array);
10891
1265e4aa 10892 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10893 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10894 (value_type (array))))
0b5d8877 10895 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10896
10897 array = ada_coerce_to_simple_array_ptr (array);
10898
714e53ab
PH
10899 /* If we have more than one level of pointer indirection,
10900 dereference the value until we get only one level. */
df407dfe
AC
10901 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10902 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10903 == TYPE_CODE_PTR))
10904 array = value_ind (array);
10905
10906 /* Make sure we really do have an array type before going further,
10907 to avoid a SEGV when trying to get the index type or the target
10908 type later down the road if the debug info generated by
10909 the compiler is incorrect or incomplete. */
df407dfe 10910 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10911 error (_("cannot take slice of non-array"));
714e53ab 10912
828292f2
JB
10913 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10914 == TYPE_CODE_PTR)
4c4b4cd2 10915 {
828292f2
JB
10916 struct type *type0 = ada_check_typedef (value_type (array));
10917
0b5d8877 10918 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10919 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10920 else
10921 {
10922 struct type *arr_type0 =
828292f2 10923 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10924
f5938064
JG
10925 return ada_value_slice_from_ptr (array, arr_type0,
10926 longest_to_int (low_bound),
10927 longest_to_int (high_bound));
4c4b4cd2
PH
10928 }
10929 }
10930 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10931 return array;
10932 else if (high_bound < low_bound)
df407dfe 10933 return empty_array (value_type (array), low_bound);
4c4b4cd2 10934 else
529cad9c
PH
10935 return ada_value_slice (array, longest_to_int (low_bound),
10936 longest_to_int (high_bound));
4c4b4cd2 10937 }
14f9c5c9 10938
4c4b4cd2
PH
10939 case UNOP_IN_RANGE:
10940 (*pos) += 2;
10941 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10942 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10943
14f9c5c9 10944 if (noside == EVAL_SKIP)
4c4b4cd2 10945 goto nosideret;
14f9c5c9 10946
4c4b4cd2
PH
10947 switch (TYPE_CODE (type))
10948 {
10949 default:
e1d5a0d2
PH
10950 lim_warning (_("Membership test incompletely implemented; "
10951 "always returns true"));
fbb06eb1
UW
10952 type = language_bool_type (exp->language_defn, exp->gdbarch);
10953 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10954
10955 case TYPE_CODE_RANGE:
030b4912
UW
10956 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10957 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10958 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10959 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10960 type = language_bool_type (exp->language_defn, exp->gdbarch);
10961 return
10962 value_from_longest (type,
4c4b4cd2
PH
10963 (value_less (arg1, arg3)
10964 || value_equal (arg1, arg3))
10965 && (value_less (arg2, arg1)
10966 || value_equal (arg2, arg1)));
10967 }
10968
10969 case BINOP_IN_BOUNDS:
14f9c5c9 10970 (*pos) += 2;
4c4b4cd2
PH
10971 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10972 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10973
4c4b4cd2
PH
10974 if (noside == EVAL_SKIP)
10975 goto nosideret;
14f9c5c9 10976
4c4b4cd2 10977 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10978 {
10979 type = language_bool_type (exp->language_defn, exp->gdbarch);
10980 return value_zero (type, not_lval);
10981 }
14f9c5c9 10982
4c4b4cd2 10983 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10984
1eea4ebd
UW
10985 type = ada_index_type (value_type (arg2), tem, "range");
10986 if (!type)
10987 type = value_type (arg1);
14f9c5c9 10988
1eea4ebd
UW
10989 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10990 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10991
f44316fa
UW
10992 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10993 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10994 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10995 return
fbb06eb1 10996 value_from_longest (type,
4c4b4cd2
PH
10997 (value_less (arg1, arg3)
10998 || value_equal (arg1, arg3))
10999 && (value_less (arg2, arg1)
11000 || value_equal (arg2, arg1)));
11001
11002 case TERNOP_IN_RANGE:
11003 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11004 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11005 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11006
11007 if (noside == EVAL_SKIP)
11008 goto nosideret;
11009
f44316fa
UW
11010 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11011 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11012 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11013 return
fbb06eb1 11014 value_from_longest (type,
4c4b4cd2
PH
11015 (value_less (arg1, arg3)
11016 || value_equal (arg1, arg3))
11017 && (value_less (arg2, arg1)
11018 || value_equal (arg2, arg1)));
11019
11020 case OP_ATR_FIRST:
11021 case OP_ATR_LAST:
11022 case OP_ATR_LENGTH:
11023 {
76a01679 11024 struct type *type_arg;
5b4ee69b 11025
76a01679
JB
11026 if (exp->elts[*pos].opcode == OP_TYPE)
11027 {
11028 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11029 arg1 = NULL;
5bc23cb3 11030 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11031 }
11032 else
11033 {
11034 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11035 type_arg = NULL;
11036 }
11037
11038 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11039 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11040 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11041 *pos += 4;
11042
11043 if (noside == EVAL_SKIP)
11044 goto nosideret;
11045
11046 if (type_arg == NULL)
11047 {
11048 arg1 = ada_coerce_ref (arg1);
11049
ad82864c 11050 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11051 arg1 = ada_coerce_to_simple_array (arg1);
11052
aa4fb036 11053 if (op == OP_ATR_LENGTH)
1eea4ebd 11054 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11055 else
11056 {
11057 type = ada_index_type (value_type (arg1), tem,
11058 ada_attribute_name (op));
11059 if (type == NULL)
11060 type = builtin_type (exp->gdbarch)->builtin_int;
11061 }
76a01679
JB
11062
11063 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11064 return allocate_value (type);
76a01679
JB
11065
11066 switch (op)
11067 {
11068 default: /* Should never happen. */
323e0a4a 11069 error (_("unexpected attribute encountered"));
76a01679 11070 case OP_ATR_FIRST:
1eea4ebd
UW
11071 return value_from_longest
11072 (type, ada_array_bound (arg1, tem, 0));
76a01679 11073 case OP_ATR_LAST:
1eea4ebd
UW
11074 return value_from_longest
11075 (type, ada_array_bound (arg1, tem, 1));
76a01679 11076 case OP_ATR_LENGTH:
1eea4ebd
UW
11077 return value_from_longest
11078 (type, ada_array_length (arg1, tem));
76a01679
JB
11079 }
11080 }
11081 else if (discrete_type_p (type_arg))
11082 {
11083 struct type *range_type;
0d5cff50 11084 const char *name = ada_type_name (type_arg);
5b4ee69b 11085
76a01679
JB
11086 range_type = NULL;
11087 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11088 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11089 if (range_type == NULL)
11090 range_type = type_arg;
11091 switch (op)
11092 {
11093 default:
323e0a4a 11094 error (_("unexpected attribute encountered"));
76a01679 11095 case OP_ATR_FIRST:
690cc4eb 11096 return value_from_longest
43bbcdc2 11097 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11098 case OP_ATR_LAST:
690cc4eb 11099 return value_from_longest
43bbcdc2 11100 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11101 case OP_ATR_LENGTH:
323e0a4a 11102 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11103 }
11104 }
11105 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11106 error (_("unimplemented type attribute"));
76a01679
JB
11107 else
11108 {
11109 LONGEST low, high;
11110
ad82864c
JB
11111 if (ada_is_constrained_packed_array_type (type_arg))
11112 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11113
aa4fb036 11114 if (op == OP_ATR_LENGTH)
1eea4ebd 11115 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11116 else
11117 {
11118 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11119 if (type == NULL)
11120 type = builtin_type (exp->gdbarch)->builtin_int;
11121 }
1eea4ebd 11122
76a01679
JB
11123 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11124 return allocate_value (type);
11125
11126 switch (op)
11127 {
11128 default:
323e0a4a 11129 error (_("unexpected attribute encountered"));
76a01679 11130 case OP_ATR_FIRST:
1eea4ebd 11131 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11132 return value_from_longest (type, low);
11133 case OP_ATR_LAST:
1eea4ebd 11134 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11135 return value_from_longest (type, high);
11136 case OP_ATR_LENGTH:
1eea4ebd
UW
11137 low = ada_array_bound_from_type (type_arg, tem, 0);
11138 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11139 return value_from_longest (type, high - low + 1);
11140 }
11141 }
14f9c5c9
AS
11142 }
11143
4c4b4cd2
PH
11144 case OP_ATR_TAG:
11145 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11146 if (noside == EVAL_SKIP)
76a01679 11147 goto nosideret;
4c4b4cd2
PH
11148
11149 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11150 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11151
11152 return ada_value_tag (arg1);
11153
11154 case OP_ATR_MIN:
11155 case OP_ATR_MAX:
11156 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11157 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11158 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11159 if (noside == EVAL_SKIP)
76a01679 11160 goto nosideret;
d2e4a39e 11161 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11162 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11163 else
f44316fa
UW
11164 {
11165 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11166 return value_binop (arg1, arg2,
11167 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11168 }
14f9c5c9 11169
4c4b4cd2
PH
11170 case OP_ATR_MODULUS:
11171 {
31dedfee 11172 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11173
5b4ee69b 11174 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11175 if (noside == EVAL_SKIP)
11176 goto nosideret;
4c4b4cd2 11177
76a01679 11178 if (!ada_is_modular_type (type_arg))
323e0a4a 11179 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11180
76a01679
JB
11181 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11182 ada_modulus (type_arg));
4c4b4cd2
PH
11183 }
11184
11185
11186 case OP_ATR_POS:
11187 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11188 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11189 if (noside == EVAL_SKIP)
76a01679 11190 goto nosideret;
3cb382c9
UW
11191 type = builtin_type (exp->gdbarch)->builtin_int;
11192 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11193 return value_zero (type, not_lval);
14f9c5c9 11194 else
3cb382c9 11195 return value_pos_atr (type, arg1);
14f9c5c9 11196
4c4b4cd2
PH
11197 case OP_ATR_SIZE:
11198 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11199 type = value_type (arg1);
11200
11201 /* If the argument is a reference, then dereference its type, since
11202 the user is really asking for the size of the actual object,
11203 not the size of the pointer. */
11204 if (TYPE_CODE (type) == TYPE_CODE_REF)
11205 type = TYPE_TARGET_TYPE (type);
11206
4c4b4cd2 11207 if (noside == EVAL_SKIP)
76a01679 11208 goto nosideret;
4c4b4cd2 11209 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11210 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11211 else
22601c15 11212 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11213 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11214
11215 case OP_ATR_VAL:
11216 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11217 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11218 type = exp->elts[pc + 2].type;
14f9c5c9 11219 if (noside == EVAL_SKIP)
76a01679 11220 goto nosideret;
4c4b4cd2 11221 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11222 return value_zero (type, not_lval);
4c4b4cd2 11223 else
76a01679 11224 return value_val_atr (type, arg1);
4c4b4cd2
PH
11225
11226 case BINOP_EXP:
11227 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11228 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11229 if (noside == EVAL_SKIP)
11230 goto nosideret;
11231 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11232 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11233 else
f44316fa
UW
11234 {
11235 /* For integer exponentiation operations,
11236 only promote the first argument. */
11237 if (is_integral_type (value_type (arg2)))
11238 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11239 else
11240 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11241
11242 return value_binop (arg1, arg2, op);
11243 }
4c4b4cd2
PH
11244
11245 case UNOP_PLUS:
11246 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11247 if (noside == EVAL_SKIP)
11248 goto nosideret;
11249 else
11250 return arg1;
11251
11252 case UNOP_ABS:
11253 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11254 if (noside == EVAL_SKIP)
11255 goto nosideret;
f44316fa 11256 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11257 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11258 return value_neg (arg1);
14f9c5c9 11259 else
4c4b4cd2 11260 return arg1;
14f9c5c9
AS
11261
11262 case UNOP_IND:
5ec18f2b 11263 preeval_pos = *pos;
6b0d7253 11264 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11265 if (noside == EVAL_SKIP)
4c4b4cd2 11266 goto nosideret;
df407dfe 11267 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11268 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11269 {
11270 if (ada_is_array_descriptor_type (type))
11271 /* GDB allows dereferencing GNAT array descriptors. */
11272 {
11273 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11274
4c4b4cd2 11275 if (arrType == NULL)
323e0a4a 11276 error (_("Attempt to dereference null array pointer."));
00a4c844 11277 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11278 }
11279 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11280 || TYPE_CODE (type) == TYPE_CODE_REF
11281 /* In C you can dereference an array to get the 1st elt. */
11282 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11283 {
5ec18f2b
JG
11284 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11285 only be determined by inspecting the object's tag.
11286 This means that we need to evaluate completely the
11287 expression in order to get its type. */
11288
023db19c
JB
11289 if ((TYPE_CODE (type) == TYPE_CODE_REF
11290 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11291 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11292 {
11293 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11294 EVAL_NORMAL);
11295 type = value_type (ada_value_ind (arg1));
11296 }
11297 else
11298 {
11299 type = to_static_fixed_type
11300 (ada_aligned_type
11301 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11302 }
c1b5a1a6 11303 ada_ensure_varsize_limit (type);
714e53ab
PH
11304 return value_zero (type, lval_memory);
11305 }
4c4b4cd2 11306 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11307 {
11308 /* GDB allows dereferencing an int. */
11309 if (expect_type == NULL)
11310 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11311 lval_memory);
11312 else
11313 {
11314 expect_type =
11315 to_static_fixed_type (ada_aligned_type (expect_type));
11316 return value_zero (expect_type, lval_memory);
11317 }
11318 }
4c4b4cd2 11319 else
323e0a4a 11320 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11321 }
0963b4bd 11322 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11323 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11324
96967637
JB
11325 if (TYPE_CODE (type) == TYPE_CODE_INT)
11326 /* GDB allows dereferencing an int. If we were given
11327 the expect_type, then use that as the target type.
11328 Otherwise, assume that the target type is an int. */
11329 {
11330 if (expect_type != NULL)
11331 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11332 arg1));
11333 else
11334 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11335 (CORE_ADDR) value_as_address (arg1));
11336 }
6b0d7253 11337
4c4b4cd2
PH
11338 if (ada_is_array_descriptor_type (type))
11339 /* GDB allows dereferencing GNAT array descriptors. */
11340 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11341 else
4c4b4cd2 11342 return ada_value_ind (arg1);
14f9c5c9
AS
11343
11344 case STRUCTOP_STRUCT:
11345 tem = longest_to_int (exp->elts[pc + 1].longconst);
11346 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11347 preeval_pos = *pos;
14f9c5c9
AS
11348 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11349 if (noside == EVAL_SKIP)
4c4b4cd2 11350 goto nosideret;
14f9c5c9 11351 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11352 {
df407dfe 11353 struct type *type1 = value_type (arg1);
5b4ee69b 11354
76a01679
JB
11355 if (ada_is_tagged_type (type1, 1))
11356 {
11357 type = ada_lookup_struct_elt_type (type1,
11358 &exp->elts[pc + 2].string,
988f6b3d 11359 1, 1);
5ec18f2b
JG
11360
11361 /* If the field is not found, check if it exists in the
11362 extension of this object's type. This means that we
11363 need to evaluate completely the expression. */
11364
76a01679 11365 if (type == NULL)
5ec18f2b
JG
11366 {
11367 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11368 EVAL_NORMAL);
11369 arg1 = ada_value_struct_elt (arg1,
11370 &exp->elts[pc + 2].string,
11371 0);
11372 arg1 = unwrap_value (arg1);
11373 type = value_type (ada_to_fixed_value (arg1));
11374 }
76a01679
JB
11375 }
11376 else
11377 type =
11378 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
988f6b3d 11379 0);
76a01679
JB
11380
11381 return value_zero (ada_aligned_type (type), lval_memory);
11382 }
14f9c5c9 11383 else
a579cd9a
MW
11384 {
11385 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11386 arg1 = unwrap_value (arg1);
11387 return ada_to_fixed_value (arg1);
11388 }
284614f0 11389
14f9c5c9 11390 case OP_TYPE:
4c4b4cd2
PH
11391 /* The value is not supposed to be used. This is here to make it
11392 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11393 (*pos) += 2;
11394 if (noside == EVAL_SKIP)
4c4b4cd2 11395 goto nosideret;
14f9c5c9 11396 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11397 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11398 else
323e0a4a 11399 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11400
11401 case OP_AGGREGATE:
11402 case OP_CHOICES:
11403 case OP_OTHERS:
11404 case OP_DISCRETE_RANGE:
11405 case OP_POSITIONAL:
11406 case OP_NAME:
11407 if (noside == EVAL_NORMAL)
11408 switch (op)
11409 {
11410 case OP_NAME:
11411 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11412 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11413 case OP_AGGREGATE:
11414 error (_("Aggregates only allowed on the right of an assignment"));
11415 default:
0963b4bd
MS
11416 internal_error (__FILE__, __LINE__,
11417 _("aggregate apparently mangled"));
52ce6436
PH
11418 }
11419
11420 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11421 *pos += oplen - 1;
11422 for (tem = 0; tem < nargs; tem += 1)
11423 ada_evaluate_subexp (NULL, exp, pos, noside);
11424 goto nosideret;
14f9c5c9
AS
11425 }
11426
11427nosideret:
22601c15 11428 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 11429}
14f9c5c9 11430\f
d2e4a39e 11431
4c4b4cd2 11432 /* Fixed point */
14f9c5c9
AS
11433
11434/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11435 type name that encodes the 'small and 'delta information.
4c4b4cd2 11436 Otherwise, return NULL. */
14f9c5c9 11437
d2e4a39e 11438static const char *
ebf56fd3 11439fixed_type_info (struct type *type)
14f9c5c9 11440{
d2e4a39e 11441 const char *name = ada_type_name (type);
14f9c5c9
AS
11442 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11443
d2e4a39e
AS
11444 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11445 {
14f9c5c9 11446 const char *tail = strstr (name, "___XF_");
5b4ee69b 11447
14f9c5c9 11448 if (tail == NULL)
4c4b4cd2 11449 return NULL;
d2e4a39e 11450 else
4c4b4cd2 11451 return tail + 5;
14f9c5c9
AS
11452 }
11453 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11454 return fixed_type_info (TYPE_TARGET_TYPE (type));
11455 else
11456 return NULL;
11457}
11458
4c4b4cd2 11459/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11460
11461int
ebf56fd3 11462ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11463{
11464 return fixed_type_info (type) != NULL;
11465}
11466
4c4b4cd2
PH
11467/* Return non-zero iff TYPE represents a System.Address type. */
11468
11469int
11470ada_is_system_address_type (struct type *type)
11471{
11472 return (TYPE_NAME (type)
11473 && strcmp (TYPE_NAME (type), "system__address") == 0);
11474}
11475
14f9c5c9
AS
11476/* Assuming that TYPE is the representation of an Ada fixed-point
11477 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 11478 delta cannot be determined. */
14f9c5c9
AS
11479
11480DOUBLEST
ebf56fd3 11481ada_delta (struct type *type)
14f9c5c9
AS
11482{
11483 const char *encoding = fixed_type_info (type);
facc390f 11484 DOUBLEST num, den;
14f9c5c9 11485
facc390f
JB
11486 /* Strictly speaking, num and den are encoded as integer. However,
11487 they may not fit into a long, and they will have to be converted
11488 to DOUBLEST anyway. So scan them as DOUBLEST. */
11489 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11490 &num, &den) < 2)
14f9c5c9 11491 return -1.0;
d2e4a39e 11492 else
facc390f 11493 return num / den;
14f9c5c9
AS
11494}
11495
11496/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11497 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
11498
11499static DOUBLEST
ebf56fd3 11500scaling_factor (struct type *type)
14f9c5c9
AS
11501{
11502 const char *encoding = fixed_type_info (type);
facc390f 11503 DOUBLEST num0, den0, num1, den1;
14f9c5c9 11504 int n;
d2e4a39e 11505
facc390f
JB
11506 /* Strictly speaking, num's and den's are encoded as integer. However,
11507 they may not fit into a long, and they will have to be converted
11508 to DOUBLEST anyway. So scan them as DOUBLEST. */
11509 n = sscanf (encoding,
11510 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
11511 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11512 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11513
11514 if (n < 2)
11515 return 1.0;
11516 else if (n == 4)
facc390f 11517 return num1 / den1;
d2e4a39e 11518 else
facc390f 11519 return num0 / den0;
14f9c5c9
AS
11520}
11521
11522
11523/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 11524 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
11525
11526DOUBLEST
ebf56fd3 11527ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 11528{
d2e4a39e 11529 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
11530}
11531
4c4b4cd2
PH
11532/* The representation of a fixed-point value of type TYPE
11533 corresponding to the value X. */
14f9c5c9
AS
11534
11535LONGEST
ebf56fd3 11536ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
11537{
11538 return (LONGEST) (x / scaling_factor (type) + 0.5);
11539}
11540
14f9c5c9 11541\f
d2e4a39e 11542
4c4b4cd2 11543 /* Range types */
14f9c5c9
AS
11544
11545/* Scan STR beginning at position K for a discriminant name, and
11546 return the value of that discriminant field of DVAL in *PX. If
11547 PNEW_K is not null, put the position of the character beyond the
11548 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11549 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11550
11551static int
108d56a4 11552scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11553 int *pnew_k)
14f9c5c9
AS
11554{
11555 static char *bound_buffer = NULL;
11556 static size_t bound_buffer_len = 0;
5da1a4d3 11557 const char *pstart, *pend, *bound;
d2e4a39e 11558 struct value *bound_val;
14f9c5c9
AS
11559
11560 if (dval == NULL || str == NULL || str[k] == '\0')
11561 return 0;
11562
5da1a4d3
SM
11563 pstart = str + k;
11564 pend = strstr (pstart, "__");
14f9c5c9
AS
11565 if (pend == NULL)
11566 {
5da1a4d3 11567 bound = pstart;
14f9c5c9
AS
11568 k += strlen (bound);
11569 }
d2e4a39e 11570 else
14f9c5c9 11571 {
5da1a4d3
SM
11572 int len = pend - pstart;
11573
11574 /* Strip __ and beyond. */
11575 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11576 strncpy (bound_buffer, pstart, len);
11577 bound_buffer[len] = '\0';
11578
14f9c5c9 11579 bound = bound_buffer;
d2e4a39e 11580 k = pend - str;
14f9c5c9 11581 }
d2e4a39e 11582
df407dfe 11583 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11584 if (bound_val == NULL)
11585 return 0;
11586
11587 *px = value_as_long (bound_val);
11588 if (pnew_k != NULL)
11589 *pnew_k = k;
11590 return 1;
11591}
11592
11593/* Value of variable named NAME in the current environment. If
11594 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11595 otherwise causes an error with message ERR_MSG. */
11596
d2e4a39e 11597static struct value *
edb0c9cb 11598get_var_value (const char *name, const char *err_msg)
14f9c5c9 11599{
d12307c1 11600 struct block_symbol *syms;
14f9c5c9
AS
11601 int nsyms;
11602
4c4b4cd2 11603 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11604 &syms);
14f9c5c9
AS
11605
11606 if (nsyms != 1)
11607 {
11608 if (err_msg == NULL)
4c4b4cd2 11609 return 0;
14f9c5c9 11610 else
8a3fe4f8 11611 error (("%s"), err_msg);
14f9c5c9
AS
11612 }
11613
d12307c1 11614 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11615}
d2e4a39e 11616
edb0c9cb
PA
11617/* Value of integer variable named NAME in the current environment.
11618 If no such variable is found, returns false. Otherwise, sets VALUE
11619 to the variable's value and returns true. */
4c4b4cd2 11620
edb0c9cb
PA
11621bool
11622get_int_var_value (const char *name, LONGEST &value)
14f9c5c9 11623{
4c4b4cd2 11624 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11625
14f9c5c9 11626 if (var_val == 0)
edb0c9cb
PA
11627 return false;
11628
11629 value = value_as_long (var_val);
11630 return true;
14f9c5c9 11631}
d2e4a39e 11632
14f9c5c9
AS
11633
11634/* Return a range type whose base type is that of the range type named
11635 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11636 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11637 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11638 corresponding range type from debug information; fall back to using it
11639 if symbol lookup fails. If a new type must be created, allocate it
11640 like ORIG_TYPE was. The bounds information, in general, is encoded
11641 in NAME, the base type given in the named range type. */
14f9c5c9 11642
d2e4a39e 11643static struct type *
28c85d6c 11644to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11645{
0d5cff50 11646 const char *name;
14f9c5c9 11647 struct type *base_type;
108d56a4 11648 const char *subtype_info;
14f9c5c9 11649
28c85d6c
JB
11650 gdb_assert (raw_type != NULL);
11651 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11652
1ce677a4 11653 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11654 base_type = TYPE_TARGET_TYPE (raw_type);
11655 else
11656 base_type = raw_type;
11657
28c85d6c 11658 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11659 subtype_info = strstr (name, "___XD");
11660 if (subtype_info == NULL)
690cc4eb 11661 {
43bbcdc2
PH
11662 LONGEST L = ada_discrete_type_low_bound (raw_type);
11663 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11664
690cc4eb
PH
11665 if (L < INT_MIN || U > INT_MAX)
11666 return raw_type;
11667 else
0c9c3474
SA
11668 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11669 L, U);
690cc4eb 11670 }
14f9c5c9
AS
11671 else
11672 {
11673 static char *name_buf = NULL;
11674 static size_t name_len = 0;
11675 int prefix_len = subtype_info - name;
11676 LONGEST L, U;
11677 struct type *type;
108d56a4 11678 const char *bounds_str;
14f9c5c9
AS
11679 int n;
11680
11681 GROW_VECT (name_buf, name_len, prefix_len + 5);
11682 strncpy (name_buf, name, prefix_len);
11683 name_buf[prefix_len] = '\0';
11684
11685 subtype_info += 5;
11686 bounds_str = strchr (subtype_info, '_');
11687 n = 1;
11688
d2e4a39e 11689 if (*subtype_info == 'L')
4c4b4cd2
PH
11690 {
11691 if (!ada_scan_number (bounds_str, n, &L, &n)
11692 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11693 return raw_type;
11694 if (bounds_str[n] == '_')
11695 n += 2;
0963b4bd 11696 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11697 n += 1;
11698 subtype_info += 1;
11699 }
d2e4a39e 11700 else
4c4b4cd2 11701 {
4c4b4cd2 11702 strcpy (name_buf + prefix_len, "___L");
edb0c9cb 11703 if (!get_int_var_value (name_buf, L))
4c4b4cd2 11704 {
323e0a4a 11705 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11706 L = 1;
11707 }
11708 }
14f9c5c9 11709
d2e4a39e 11710 if (*subtype_info == 'U')
4c4b4cd2
PH
11711 {
11712 if (!ada_scan_number (bounds_str, n, &U, &n)
11713 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11714 return raw_type;
11715 }
d2e4a39e 11716 else
4c4b4cd2 11717 {
4c4b4cd2 11718 strcpy (name_buf + prefix_len, "___U");
edb0c9cb 11719 if (!get_int_var_value (name_buf, U))
4c4b4cd2 11720 {
323e0a4a 11721 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11722 U = L;
11723 }
11724 }
14f9c5c9 11725
0c9c3474
SA
11726 type = create_static_range_type (alloc_type_copy (raw_type),
11727 base_type, L, U);
d2e4a39e 11728 TYPE_NAME (type) = name;
14f9c5c9
AS
11729 return type;
11730 }
11731}
11732
4c4b4cd2
PH
11733/* True iff NAME is the name of a range type. */
11734
14f9c5c9 11735int
d2e4a39e 11736ada_is_range_type_name (const char *name)
14f9c5c9
AS
11737{
11738 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11739}
14f9c5c9 11740\f
d2e4a39e 11741
4c4b4cd2
PH
11742 /* Modular types */
11743
11744/* True iff TYPE is an Ada modular type. */
14f9c5c9 11745
14f9c5c9 11746int
d2e4a39e 11747ada_is_modular_type (struct type *type)
14f9c5c9 11748{
18af8284 11749 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11750
11751 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11752 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11753 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11754}
11755
4c4b4cd2
PH
11756/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11757
61ee279c 11758ULONGEST
0056e4d5 11759ada_modulus (struct type *type)
14f9c5c9 11760{
43bbcdc2 11761 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11762}
d2e4a39e 11763\f
f7f9143b
JB
11764
11765/* Ada exception catchpoint support:
11766 ---------------------------------
11767
11768 We support 3 kinds of exception catchpoints:
11769 . catchpoints on Ada exceptions
11770 . catchpoints on unhandled Ada exceptions
11771 . catchpoints on failed assertions
11772
11773 Exceptions raised during failed assertions, or unhandled exceptions
11774 could perfectly be caught with the general catchpoint on Ada exceptions.
11775 However, we can easily differentiate these two special cases, and having
11776 the option to distinguish these two cases from the rest can be useful
11777 to zero-in on certain situations.
11778
11779 Exception catchpoints are a specialized form of breakpoint,
11780 since they rely on inserting breakpoints inside known routines
11781 of the GNAT runtime. The implementation therefore uses a standard
11782 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11783 of breakpoint_ops.
11784
0259addd
JB
11785 Support in the runtime for exception catchpoints have been changed
11786 a few times already, and these changes affect the implementation
11787 of these catchpoints. In order to be able to support several
11788 variants of the runtime, we use a sniffer that will determine
28010a5d 11789 the runtime variant used by the program being debugged. */
f7f9143b 11790
82eacd52
JB
11791/* Ada's standard exceptions.
11792
11793 The Ada 83 standard also defined Numeric_Error. But there so many
11794 situations where it was unclear from the Ada 83 Reference Manual
11795 (RM) whether Constraint_Error or Numeric_Error should be raised,
11796 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11797 Interpretation saying that anytime the RM says that Numeric_Error
11798 should be raised, the implementation may raise Constraint_Error.
11799 Ada 95 went one step further and pretty much removed Numeric_Error
11800 from the list of standard exceptions (it made it a renaming of
11801 Constraint_Error, to help preserve compatibility when compiling
11802 an Ada83 compiler). As such, we do not include Numeric_Error from
11803 this list of standard exceptions. */
3d0b0fa3 11804
a121b7c1 11805static const char *standard_exc[] = {
3d0b0fa3
JB
11806 "constraint_error",
11807 "program_error",
11808 "storage_error",
11809 "tasking_error"
11810};
11811
0259addd
JB
11812typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11813
11814/* A structure that describes how to support exception catchpoints
11815 for a given executable. */
11816
11817struct exception_support_info
11818{
11819 /* The name of the symbol to break on in order to insert
11820 a catchpoint on exceptions. */
11821 const char *catch_exception_sym;
11822
11823 /* The name of the symbol to break on in order to insert
11824 a catchpoint on unhandled exceptions. */
11825 const char *catch_exception_unhandled_sym;
11826
11827 /* The name of the symbol to break on in order to insert
11828 a catchpoint on failed assertions. */
11829 const char *catch_assert_sym;
11830
11831 /* Assuming that the inferior just triggered an unhandled exception
11832 catchpoint, this function is responsible for returning the address
11833 in inferior memory where the name of that exception is stored.
11834 Return zero if the address could not be computed. */
11835 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11836};
11837
11838static CORE_ADDR ada_unhandled_exception_name_addr (void);
11839static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11840
11841/* The following exception support info structure describes how to
11842 implement exception catchpoints with the latest version of the
11843 Ada runtime (as of 2007-03-06). */
11844
11845static const struct exception_support_info default_exception_support_info =
11846{
11847 "__gnat_debug_raise_exception", /* catch_exception_sym */
11848 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11849 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11850 ada_unhandled_exception_name_addr
11851};
11852
11853/* The following exception support info structure describes how to
11854 implement exception catchpoints with a slightly older version
11855 of the Ada runtime. */
11856
11857static const struct exception_support_info exception_support_info_fallback =
11858{
11859 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11860 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11861 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11862 ada_unhandled_exception_name_addr_from_raise
11863};
11864
f17011e0
JB
11865/* Return nonzero if we can detect the exception support routines
11866 described in EINFO.
11867
11868 This function errors out if an abnormal situation is detected
11869 (for instance, if we find the exception support routines, but
11870 that support is found to be incomplete). */
11871
11872static int
11873ada_has_this_exception_support (const struct exception_support_info *einfo)
11874{
11875 struct symbol *sym;
11876
11877 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11878 that should be compiled with debugging information. As a result, we
11879 expect to find that symbol in the symtabs. */
11880
11881 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11882 if (sym == NULL)
a6af7abe
JB
11883 {
11884 /* Perhaps we did not find our symbol because the Ada runtime was
11885 compiled without debugging info, or simply stripped of it.
11886 It happens on some GNU/Linux distributions for instance, where
11887 users have to install a separate debug package in order to get
11888 the runtime's debugging info. In that situation, let the user
11889 know why we cannot insert an Ada exception catchpoint.
11890
11891 Note: Just for the purpose of inserting our Ada exception
11892 catchpoint, we could rely purely on the associated minimal symbol.
11893 But we would be operating in degraded mode anyway, since we are
11894 still lacking the debugging info needed later on to extract
11895 the name of the exception being raised (this name is printed in
11896 the catchpoint message, and is also used when trying to catch
11897 a specific exception). We do not handle this case for now. */
3b7344d5 11898 struct bound_minimal_symbol msym
1c8e84b0
JB
11899 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11900
3b7344d5 11901 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11902 error (_("Your Ada runtime appears to be missing some debugging "
11903 "information.\nCannot insert Ada exception catchpoint "
11904 "in this configuration."));
11905
11906 return 0;
11907 }
f17011e0
JB
11908
11909 /* Make sure that the symbol we found corresponds to a function. */
11910
11911 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11912 error (_("Symbol \"%s\" is not a function (class = %d)"),
11913 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11914
11915 return 1;
11916}
11917
0259addd
JB
11918/* Inspect the Ada runtime and determine which exception info structure
11919 should be used to provide support for exception catchpoints.
11920
3eecfa55
JB
11921 This function will always set the per-inferior exception_info,
11922 or raise an error. */
0259addd
JB
11923
11924static void
11925ada_exception_support_info_sniffer (void)
11926{
3eecfa55 11927 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11928
11929 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11930 if (data->exception_info != NULL)
0259addd
JB
11931 return;
11932
11933 /* Check the latest (default) exception support info. */
f17011e0 11934 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11935 {
3eecfa55 11936 data->exception_info = &default_exception_support_info;
0259addd
JB
11937 return;
11938 }
11939
11940 /* Try our fallback exception suport info. */
f17011e0 11941 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11942 {
3eecfa55 11943 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11944 return;
11945 }
11946
11947 /* Sometimes, it is normal for us to not be able to find the routine
11948 we are looking for. This happens when the program is linked with
11949 the shared version of the GNAT runtime, and the program has not been
11950 started yet. Inform the user of these two possible causes if
11951 applicable. */
11952
ccefe4c4 11953 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11954 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11955
11956 /* If the symbol does not exist, then check that the program is
11957 already started, to make sure that shared libraries have been
11958 loaded. If it is not started, this may mean that the symbol is
11959 in a shared library. */
11960
11961 if (ptid_get_pid (inferior_ptid) == 0)
11962 error (_("Unable to insert catchpoint. Try to start the program first."));
11963
11964 /* At this point, we know that we are debugging an Ada program and
11965 that the inferior has been started, but we still are not able to
0963b4bd 11966 find the run-time symbols. That can mean that we are in
0259addd
JB
11967 configurable run time mode, or that a-except as been optimized
11968 out by the linker... In any case, at this point it is not worth
11969 supporting this feature. */
11970
7dda8cff 11971 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11972}
11973
f7f9143b
JB
11974/* True iff FRAME is very likely to be that of a function that is
11975 part of the runtime system. This is all very heuristic, but is
11976 intended to be used as advice as to what frames are uninteresting
11977 to most users. */
11978
11979static int
11980is_known_support_routine (struct frame_info *frame)
11981{
55b87a52 11982 char *func_name;
692465f1 11983 enum language func_lang;
f7f9143b 11984 int i;
f35a17b5 11985 const char *fullname;
f7f9143b 11986
4ed6b5be
JB
11987 /* If this code does not have any debugging information (no symtab),
11988 This cannot be any user code. */
f7f9143b 11989
51abb421 11990 symtab_and_line sal = find_frame_sal (frame);
f7f9143b
JB
11991 if (sal.symtab == NULL)
11992 return 1;
11993
4ed6b5be
JB
11994 /* If there is a symtab, but the associated source file cannot be
11995 located, then assume this is not user code: Selecting a frame
11996 for which we cannot display the code would not be very helpful
11997 for the user. This should also take care of case such as VxWorks
11998 where the kernel has some debugging info provided for a few units. */
f7f9143b 11999
f35a17b5
JK
12000 fullname = symtab_to_fullname (sal.symtab);
12001 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12002 return 1;
12003
4ed6b5be
JB
12004 /* Check the unit filename againt the Ada runtime file naming.
12005 We also check the name of the objfile against the name of some
12006 known system libraries that sometimes come with debugging info
12007 too. */
12008
f7f9143b
JB
12009 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12010 {
12011 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12012 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12013 return 1;
eb822aa6
DE
12014 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12015 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12016 return 1;
f7f9143b
JB
12017 }
12018
4ed6b5be 12019 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12020
e9e07ba6 12021 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
12022 if (func_name == NULL)
12023 return 1;
12024
12025 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12026 {
12027 re_comp (known_auxiliary_function_name_patterns[i]);
12028 if (re_exec (func_name))
55b87a52
KS
12029 {
12030 xfree (func_name);
12031 return 1;
12032 }
f7f9143b
JB
12033 }
12034
55b87a52 12035 xfree (func_name);
f7f9143b
JB
12036 return 0;
12037}
12038
12039/* Find the first frame that contains debugging information and that is not
12040 part of the Ada run-time, starting from FI and moving upward. */
12041
0ef643c8 12042void
f7f9143b
JB
12043ada_find_printable_frame (struct frame_info *fi)
12044{
12045 for (; fi != NULL; fi = get_prev_frame (fi))
12046 {
12047 if (!is_known_support_routine (fi))
12048 {
12049 select_frame (fi);
12050 break;
12051 }
12052 }
12053
12054}
12055
12056/* Assuming that the inferior just triggered an unhandled exception
12057 catchpoint, return the address in inferior memory where the name
12058 of the exception is stored.
12059
12060 Return zero if the address could not be computed. */
12061
12062static CORE_ADDR
12063ada_unhandled_exception_name_addr (void)
0259addd
JB
12064{
12065 return parse_and_eval_address ("e.full_name");
12066}
12067
12068/* Same as ada_unhandled_exception_name_addr, except that this function
12069 should be used when the inferior uses an older version of the runtime,
12070 where the exception name needs to be extracted from a specific frame
12071 several frames up in the callstack. */
12072
12073static CORE_ADDR
12074ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12075{
12076 int frame_level;
12077 struct frame_info *fi;
3eecfa55 12078 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 12079 struct cleanup *old_chain;
f7f9143b
JB
12080
12081 /* To determine the name of this exception, we need to select
12082 the frame corresponding to RAISE_SYM_NAME. This frame is
12083 at least 3 levels up, so we simply skip the first 3 frames
12084 without checking the name of their associated function. */
12085 fi = get_current_frame ();
12086 for (frame_level = 0; frame_level < 3; frame_level += 1)
12087 if (fi != NULL)
12088 fi = get_prev_frame (fi);
12089
55b87a52 12090 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
12091 while (fi != NULL)
12092 {
55b87a52 12093 char *func_name;
692465f1
JB
12094 enum language func_lang;
12095
e9e07ba6 12096 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
12097 if (func_name != NULL)
12098 {
12099 make_cleanup (xfree, func_name);
12100
12101 if (strcmp (func_name,
12102 data->exception_info->catch_exception_sym) == 0)
12103 break; /* We found the frame we were looking for... */
12104 fi = get_prev_frame (fi);
12105 }
f7f9143b 12106 }
55b87a52 12107 do_cleanups (old_chain);
f7f9143b
JB
12108
12109 if (fi == NULL)
12110 return 0;
12111
12112 select_frame (fi);
12113 return parse_and_eval_address ("id.full_name");
12114}
12115
12116/* Assuming the inferior just triggered an Ada exception catchpoint
12117 (of any type), return the address in inferior memory where the name
12118 of the exception is stored, if applicable.
12119
45db7c09
PA
12120 Assumes the selected frame is the current frame.
12121
f7f9143b
JB
12122 Return zero if the address could not be computed, or if not relevant. */
12123
12124static CORE_ADDR
761269c8 12125ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12126 struct breakpoint *b)
12127{
3eecfa55
JB
12128 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12129
f7f9143b
JB
12130 switch (ex)
12131 {
761269c8 12132 case ada_catch_exception:
f7f9143b
JB
12133 return (parse_and_eval_address ("e.full_name"));
12134 break;
12135
761269c8 12136 case ada_catch_exception_unhandled:
3eecfa55 12137 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
12138 break;
12139
761269c8 12140 case ada_catch_assert:
f7f9143b
JB
12141 return 0; /* Exception name is not relevant in this case. */
12142 break;
12143
12144 default:
12145 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12146 break;
12147 }
12148
12149 return 0; /* Should never be reached. */
12150}
12151
12152/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12153 any error that ada_exception_name_addr_1 might cause to be thrown.
12154 When an error is intercepted, a warning with the error message is printed,
12155 and zero is returned. */
12156
12157static CORE_ADDR
761269c8 12158ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12159 struct breakpoint *b)
12160{
f7f9143b
JB
12161 CORE_ADDR result = 0;
12162
492d29ea 12163 TRY
f7f9143b
JB
12164 {
12165 result = ada_exception_name_addr_1 (ex, b);
12166 }
12167
492d29ea 12168 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12169 {
12170 warning (_("failed to get exception name: %s"), e.message);
12171 return 0;
12172 }
492d29ea 12173 END_CATCH
f7f9143b
JB
12174
12175 return result;
12176}
12177
28010a5d
PA
12178static char *ada_exception_catchpoint_cond_string (const char *excep_string);
12179
12180/* Ada catchpoints.
12181
12182 In the case of catchpoints on Ada exceptions, the catchpoint will
12183 stop the target on every exception the program throws. When a user
12184 specifies the name of a specific exception, we translate this
12185 request into a condition expression (in text form), and then parse
12186 it into an expression stored in each of the catchpoint's locations.
12187 We then use this condition to check whether the exception that was
12188 raised is the one the user is interested in. If not, then the
12189 target is resumed again. We store the name of the requested
12190 exception, in order to be able to re-set the condition expression
12191 when symbols change. */
12192
12193/* An instance of this type is used to represent an Ada catchpoint
5625a286 12194 breakpoint location. */
28010a5d 12195
5625a286 12196class ada_catchpoint_location : public bp_location
28010a5d 12197{
5625a286
PA
12198public:
12199 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12200 : bp_location (ops, owner)
12201 {}
28010a5d
PA
12202
12203 /* The condition that checks whether the exception that was raised
12204 is the specific exception the user specified on catchpoint
12205 creation. */
4d01a485 12206 expression_up excep_cond_expr;
28010a5d
PA
12207};
12208
12209/* Implement the DTOR method in the bp_location_ops structure for all
12210 Ada exception catchpoint kinds. */
12211
12212static void
12213ada_catchpoint_location_dtor (struct bp_location *bl)
12214{
12215 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12216
4d01a485 12217 al->excep_cond_expr.reset ();
28010a5d
PA
12218}
12219
12220/* The vtable to be used in Ada catchpoint locations. */
12221
12222static const struct bp_location_ops ada_catchpoint_location_ops =
12223{
12224 ada_catchpoint_location_dtor
12225};
12226
c1fc2657 12227/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12228
c1fc2657 12229struct ada_catchpoint : public breakpoint
28010a5d 12230{
c1fc2657 12231 ~ada_catchpoint () override;
28010a5d
PA
12232
12233 /* The name of the specific exception the user specified. */
12234 char *excep_string;
12235};
12236
12237/* Parse the exception condition string in the context of each of the
12238 catchpoint's locations, and store them for later evaluation. */
12239
12240static void
12241create_excep_cond_exprs (struct ada_catchpoint *c)
12242{
12243 struct cleanup *old_chain;
12244 struct bp_location *bl;
12245 char *cond_string;
12246
12247 /* Nothing to do if there's no specific exception to catch. */
12248 if (c->excep_string == NULL)
12249 return;
12250
12251 /* Same if there are no locations... */
c1fc2657 12252 if (c->loc == NULL)
28010a5d
PA
12253 return;
12254
12255 /* Compute the condition expression in text form, from the specific
12256 expection we want to catch. */
12257 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
12258 old_chain = make_cleanup (xfree, cond_string);
12259
12260 /* Iterate over all the catchpoint's locations, and parse an
12261 expression for each. */
c1fc2657 12262 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12263 {
12264 struct ada_catchpoint_location *ada_loc
12265 = (struct ada_catchpoint_location *) bl;
4d01a485 12266 expression_up exp;
28010a5d
PA
12267
12268 if (!bl->shlib_disabled)
12269 {
bbc13ae3 12270 const char *s;
28010a5d
PA
12271
12272 s = cond_string;
492d29ea 12273 TRY
28010a5d 12274 {
036e657b
JB
12275 exp = parse_exp_1 (&s, bl->address,
12276 block_for_pc (bl->address),
12277 0);
28010a5d 12278 }
492d29ea 12279 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12280 {
12281 warning (_("failed to reevaluate internal exception condition "
12282 "for catchpoint %d: %s"),
c1fc2657 12283 c->number, e.message);
849f2b52 12284 }
492d29ea 12285 END_CATCH
28010a5d
PA
12286 }
12287
b22e99fd 12288 ada_loc->excep_cond_expr = std::move (exp);
28010a5d
PA
12289 }
12290
12291 do_cleanups (old_chain);
12292}
12293
c1fc2657 12294/* ada_catchpoint destructor. */
28010a5d 12295
c1fc2657 12296ada_catchpoint::~ada_catchpoint ()
28010a5d 12297{
c1fc2657 12298 xfree (this->excep_string);
28010a5d
PA
12299}
12300
12301/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12302 structure for all exception catchpoint kinds. */
12303
12304static struct bp_location *
761269c8 12305allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12306 struct breakpoint *self)
12307{
5625a286 12308 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12309}
12310
12311/* Implement the RE_SET method in the breakpoint_ops structure for all
12312 exception catchpoint kinds. */
12313
12314static void
761269c8 12315re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12316{
12317 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12318
12319 /* Call the base class's method. This updates the catchpoint's
12320 locations. */
2060206e 12321 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12322
12323 /* Reparse the exception conditional expressions. One for each
12324 location. */
12325 create_excep_cond_exprs (c);
12326}
12327
12328/* Returns true if we should stop for this breakpoint hit. If the
12329 user specified a specific exception, we only want to cause a stop
12330 if the program thrown that exception. */
12331
12332static int
12333should_stop_exception (const struct bp_location *bl)
12334{
12335 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12336 const struct ada_catchpoint_location *ada_loc
12337 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12338 int stop;
12339
12340 /* With no specific exception, should always stop. */
12341 if (c->excep_string == NULL)
12342 return 1;
12343
12344 if (ada_loc->excep_cond_expr == NULL)
12345 {
12346 /* We will have a NULL expression if back when we were creating
12347 the expressions, this location's had failed to parse. */
12348 return 1;
12349 }
12350
12351 stop = 1;
492d29ea 12352 TRY
28010a5d
PA
12353 {
12354 struct value *mark;
12355
12356 mark = value_mark ();
4d01a485 12357 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12358 value_free_to_mark (mark);
12359 }
492d29ea
PA
12360 CATCH (ex, RETURN_MASK_ALL)
12361 {
12362 exception_fprintf (gdb_stderr, ex,
12363 _("Error in testing exception condition:\n"));
12364 }
12365 END_CATCH
12366
28010a5d
PA
12367 return stop;
12368}
12369
12370/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12371 for all exception catchpoint kinds. */
12372
12373static void
761269c8 12374check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12375{
12376 bs->stop = should_stop_exception (bs->bp_location_at);
12377}
12378
f7f9143b
JB
12379/* Implement the PRINT_IT method in the breakpoint_ops structure
12380 for all exception catchpoint kinds. */
12381
12382static enum print_stop_action
761269c8 12383print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12384{
79a45e25 12385 struct ui_out *uiout = current_uiout;
348d480f
PA
12386 struct breakpoint *b = bs->breakpoint_at;
12387
956a9fb9 12388 annotate_catchpoint (b->number);
f7f9143b 12389
112e8700 12390 if (uiout->is_mi_like_p ())
f7f9143b 12391 {
112e8700 12392 uiout->field_string ("reason",
956a9fb9 12393 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12394 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12395 }
12396
112e8700
SM
12397 uiout->text (b->disposition == disp_del
12398 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12399 uiout->field_int ("bkptno", b->number);
12400 uiout->text (", ");
f7f9143b 12401
45db7c09
PA
12402 /* ada_exception_name_addr relies on the selected frame being the
12403 current frame. Need to do this here because this function may be
12404 called more than once when printing a stop, and below, we'll
12405 select the first frame past the Ada run-time (see
12406 ada_find_printable_frame). */
12407 select_frame (get_current_frame ());
12408
f7f9143b
JB
12409 switch (ex)
12410 {
761269c8
JB
12411 case ada_catch_exception:
12412 case ada_catch_exception_unhandled:
956a9fb9
JB
12413 {
12414 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12415 char exception_name[256];
12416
12417 if (addr != 0)
12418 {
c714b426
PA
12419 read_memory (addr, (gdb_byte *) exception_name,
12420 sizeof (exception_name) - 1);
956a9fb9
JB
12421 exception_name [sizeof (exception_name) - 1] = '\0';
12422 }
12423 else
12424 {
12425 /* For some reason, we were unable to read the exception
12426 name. This could happen if the Runtime was compiled
12427 without debugging info, for instance. In that case,
12428 just replace the exception name by the generic string
12429 "exception" - it will read as "an exception" in the
12430 notification we are about to print. */
967cff16 12431 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12432 }
12433 /* In the case of unhandled exception breakpoints, we print
12434 the exception name as "unhandled EXCEPTION_NAME", to make
12435 it clearer to the user which kind of catchpoint just got
12436 hit. We used ui_out_text to make sure that this extra
12437 info does not pollute the exception name in the MI case. */
761269c8 12438 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12439 uiout->text ("unhandled ");
12440 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12441 }
12442 break;
761269c8 12443 case ada_catch_assert:
956a9fb9
JB
12444 /* In this case, the name of the exception is not really
12445 important. Just print "failed assertion" to make it clearer
12446 that his program just hit an assertion-failure catchpoint.
12447 We used ui_out_text because this info does not belong in
12448 the MI output. */
112e8700 12449 uiout->text ("failed assertion");
956a9fb9 12450 break;
f7f9143b 12451 }
112e8700 12452 uiout->text (" at ");
956a9fb9 12453 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12454
12455 return PRINT_SRC_AND_LOC;
12456}
12457
12458/* Implement the PRINT_ONE method in the breakpoint_ops structure
12459 for all exception catchpoint kinds. */
12460
12461static void
761269c8 12462print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12463 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12464{
79a45e25 12465 struct ui_out *uiout = current_uiout;
28010a5d 12466 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12467 struct value_print_options opts;
12468
12469 get_user_print_options (&opts);
12470 if (opts.addressprint)
f7f9143b
JB
12471 {
12472 annotate_field (4);
112e8700 12473 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12474 }
12475
12476 annotate_field (5);
a6d9a66e 12477 *last_loc = b->loc;
f7f9143b
JB
12478 switch (ex)
12479 {
761269c8 12480 case ada_catch_exception:
28010a5d 12481 if (c->excep_string != NULL)
f7f9143b 12482 {
28010a5d
PA
12483 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12484
112e8700 12485 uiout->field_string ("what", msg);
f7f9143b
JB
12486 xfree (msg);
12487 }
12488 else
112e8700 12489 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12490
12491 break;
12492
761269c8 12493 case ada_catch_exception_unhandled:
112e8700 12494 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12495 break;
12496
761269c8 12497 case ada_catch_assert:
112e8700 12498 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12499 break;
12500
12501 default:
12502 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12503 break;
12504 }
12505}
12506
12507/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12508 for all exception catchpoint kinds. */
12509
12510static void
761269c8 12511print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12512 struct breakpoint *b)
12513{
28010a5d 12514 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12515 struct ui_out *uiout = current_uiout;
28010a5d 12516
112e8700 12517 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12518 : _("Catchpoint "));
112e8700
SM
12519 uiout->field_int ("bkptno", b->number);
12520 uiout->text (": ");
00eb2c4a 12521
f7f9143b
JB
12522 switch (ex)
12523 {
761269c8 12524 case ada_catch_exception:
28010a5d 12525 if (c->excep_string != NULL)
00eb2c4a
JB
12526 {
12527 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12528 struct cleanup *old_chain = make_cleanup (xfree, info);
12529
112e8700 12530 uiout->text (info);
00eb2c4a
JB
12531 do_cleanups (old_chain);
12532 }
f7f9143b 12533 else
112e8700 12534 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12535 break;
12536
761269c8 12537 case ada_catch_exception_unhandled:
112e8700 12538 uiout->text (_("unhandled Ada exceptions"));
f7f9143b
JB
12539 break;
12540
761269c8 12541 case ada_catch_assert:
112e8700 12542 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12543 break;
12544
12545 default:
12546 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12547 break;
12548 }
12549}
12550
6149aea9
PA
12551/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12552 for all exception catchpoint kinds. */
12553
12554static void
761269c8 12555print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12556 struct breakpoint *b, struct ui_file *fp)
12557{
28010a5d
PA
12558 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12559
6149aea9
PA
12560 switch (ex)
12561 {
761269c8 12562 case ada_catch_exception:
6149aea9 12563 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12564 if (c->excep_string != NULL)
12565 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12566 break;
12567
761269c8 12568 case ada_catch_exception_unhandled:
78076abc 12569 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12570 break;
12571
761269c8 12572 case ada_catch_assert:
6149aea9
PA
12573 fprintf_filtered (fp, "catch assert");
12574 break;
12575
12576 default:
12577 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12578 }
d9b3f62e 12579 print_recreate_thread (b, fp);
6149aea9
PA
12580}
12581
f7f9143b
JB
12582/* Virtual table for "catch exception" breakpoints. */
12583
28010a5d
PA
12584static struct bp_location *
12585allocate_location_catch_exception (struct breakpoint *self)
12586{
761269c8 12587 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12588}
12589
12590static void
12591re_set_catch_exception (struct breakpoint *b)
12592{
761269c8 12593 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12594}
12595
12596static void
12597check_status_catch_exception (bpstat bs)
12598{
761269c8 12599 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12600}
12601
f7f9143b 12602static enum print_stop_action
348d480f 12603print_it_catch_exception (bpstat bs)
f7f9143b 12604{
761269c8 12605 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12606}
12607
12608static void
a6d9a66e 12609print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12610{
761269c8 12611 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12612}
12613
12614static void
12615print_mention_catch_exception (struct breakpoint *b)
12616{
761269c8 12617 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12618}
12619
6149aea9
PA
12620static void
12621print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12622{
761269c8 12623 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12624}
12625
2060206e 12626static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12627
12628/* Virtual table for "catch exception unhandled" breakpoints. */
12629
28010a5d
PA
12630static struct bp_location *
12631allocate_location_catch_exception_unhandled (struct breakpoint *self)
12632{
761269c8 12633 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12634}
12635
12636static void
12637re_set_catch_exception_unhandled (struct breakpoint *b)
12638{
761269c8 12639 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12640}
12641
12642static void
12643check_status_catch_exception_unhandled (bpstat bs)
12644{
761269c8 12645 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12646}
12647
f7f9143b 12648static enum print_stop_action
348d480f 12649print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12650{
761269c8 12651 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12652}
12653
12654static void
a6d9a66e
UW
12655print_one_catch_exception_unhandled (struct breakpoint *b,
12656 struct bp_location **last_loc)
f7f9143b 12657{
761269c8 12658 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12659}
12660
12661static void
12662print_mention_catch_exception_unhandled (struct breakpoint *b)
12663{
761269c8 12664 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12665}
12666
6149aea9
PA
12667static void
12668print_recreate_catch_exception_unhandled (struct breakpoint *b,
12669 struct ui_file *fp)
12670{
761269c8 12671 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12672}
12673
2060206e 12674static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12675
12676/* Virtual table for "catch assert" breakpoints. */
12677
28010a5d
PA
12678static struct bp_location *
12679allocate_location_catch_assert (struct breakpoint *self)
12680{
761269c8 12681 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12682}
12683
12684static void
12685re_set_catch_assert (struct breakpoint *b)
12686{
761269c8 12687 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12688}
12689
12690static void
12691check_status_catch_assert (bpstat bs)
12692{
761269c8 12693 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12694}
12695
f7f9143b 12696static enum print_stop_action
348d480f 12697print_it_catch_assert (bpstat bs)
f7f9143b 12698{
761269c8 12699 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12700}
12701
12702static void
a6d9a66e 12703print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12704{
761269c8 12705 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12706}
12707
12708static void
12709print_mention_catch_assert (struct breakpoint *b)
12710{
761269c8 12711 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12712}
12713
6149aea9
PA
12714static void
12715print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12716{
761269c8 12717 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12718}
12719
2060206e 12720static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12721
f7f9143b
JB
12722/* Return a newly allocated copy of the first space-separated token
12723 in ARGSP, and then adjust ARGSP to point immediately after that
12724 token.
12725
12726 Return NULL if ARGPS does not contain any more tokens. */
12727
12728static char *
a121b7c1 12729ada_get_next_arg (const char **argsp)
f7f9143b 12730{
a121b7c1
PA
12731 const char *args = *argsp;
12732 const char *end;
f7f9143b
JB
12733 char *result;
12734
f1735a53 12735 args = skip_spaces (args);
f7f9143b
JB
12736 if (args[0] == '\0')
12737 return NULL; /* No more arguments. */
12738
12739 /* Find the end of the current argument. */
12740
f1735a53 12741 end = skip_to_space (args);
f7f9143b
JB
12742
12743 /* Adjust ARGSP to point to the start of the next argument. */
12744
12745 *argsp = end;
12746
12747 /* Make a copy of the current argument and return it. */
12748
224c3ddb 12749 result = (char *) xmalloc (end - args + 1);
f7f9143b
JB
12750 strncpy (result, args, end - args);
12751 result[end - args] = '\0';
12752
12753 return result;
12754}
12755
12756/* Split the arguments specified in a "catch exception" command.
12757 Set EX to the appropriate catchpoint type.
28010a5d 12758 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12759 specified by the user.
12760 If a condition is found at the end of the arguments, the condition
12761 expression is stored in COND_STRING (memory must be deallocated
12762 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12763
12764static void
a121b7c1 12765catch_ada_exception_command_split (const char *args,
761269c8 12766 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12767 char **excep_string,
12768 char **cond_string)
f7f9143b
JB
12769{
12770 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12771 char *exception_name;
5845583d 12772 char *cond = NULL;
f7f9143b
JB
12773
12774 exception_name = ada_get_next_arg (&args);
5845583d
JB
12775 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12776 {
12777 /* This is not an exception name; this is the start of a condition
12778 expression for a catchpoint on all exceptions. So, "un-get"
12779 this token, and set exception_name to NULL. */
12780 xfree (exception_name);
12781 exception_name = NULL;
12782 args -= 2;
12783 }
f7f9143b
JB
12784 make_cleanup (xfree, exception_name);
12785
5845583d 12786 /* Check to see if we have a condition. */
f7f9143b 12787
f1735a53 12788 args = skip_spaces (args);
61012eef 12789 if (startswith (args, "if")
5845583d
JB
12790 && (isspace (args[2]) || args[2] == '\0'))
12791 {
12792 args += 2;
f1735a53 12793 args = skip_spaces (args);
5845583d
JB
12794
12795 if (args[0] == '\0')
12796 error (_("Condition missing after `if' keyword"));
12797 cond = xstrdup (args);
12798 make_cleanup (xfree, cond);
12799
12800 args += strlen (args);
12801 }
12802
12803 /* Check that we do not have any more arguments. Anything else
12804 is unexpected. */
f7f9143b
JB
12805
12806 if (args[0] != '\0')
12807 error (_("Junk at end of expression"));
12808
12809 discard_cleanups (old_chain);
12810
12811 if (exception_name == NULL)
12812 {
12813 /* Catch all exceptions. */
761269c8 12814 *ex = ada_catch_exception;
28010a5d 12815 *excep_string = NULL;
f7f9143b
JB
12816 }
12817 else if (strcmp (exception_name, "unhandled") == 0)
12818 {
12819 /* Catch unhandled exceptions. */
761269c8 12820 *ex = ada_catch_exception_unhandled;
28010a5d 12821 *excep_string = NULL;
f7f9143b
JB
12822 }
12823 else
12824 {
12825 /* Catch a specific exception. */
761269c8 12826 *ex = ada_catch_exception;
28010a5d 12827 *excep_string = exception_name;
f7f9143b 12828 }
5845583d 12829 *cond_string = cond;
f7f9143b
JB
12830}
12831
12832/* Return the name of the symbol on which we should break in order to
12833 implement a catchpoint of the EX kind. */
12834
12835static const char *
761269c8 12836ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12837{
3eecfa55
JB
12838 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12839
12840 gdb_assert (data->exception_info != NULL);
0259addd 12841
f7f9143b
JB
12842 switch (ex)
12843 {
761269c8 12844 case ada_catch_exception:
3eecfa55 12845 return (data->exception_info->catch_exception_sym);
f7f9143b 12846 break;
761269c8 12847 case ada_catch_exception_unhandled:
3eecfa55 12848 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12849 break;
761269c8 12850 case ada_catch_assert:
3eecfa55 12851 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12852 break;
12853 default:
12854 internal_error (__FILE__, __LINE__,
12855 _("unexpected catchpoint kind (%d)"), ex);
12856 }
12857}
12858
12859/* Return the breakpoint ops "virtual table" used for catchpoints
12860 of the EX kind. */
12861
c0a91b2b 12862static const struct breakpoint_ops *
761269c8 12863ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12864{
12865 switch (ex)
12866 {
761269c8 12867 case ada_catch_exception:
f7f9143b
JB
12868 return (&catch_exception_breakpoint_ops);
12869 break;
761269c8 12870 case ada_catch_exception_unhandled:
f7f9143b
JB
12871 return (&catch_exception_unhandled_breakpoint_ops);
12872 break;
761269c8 12873 case ada_catch_assert:
f7f9143b
JB
12874 return (&catch_assert_breakpoint_ops);
12875 break;
12876 default:
12877 internal_error (__FILE__, __LINE__,
12878 _("unexpected catchpoint kind (%d)"), ex);
12879 }
12880}
12881
12882/* Return the condition that will be used to match the current exception
12883 being raised with the exception that the user wants to catch. This
12884 assumes that this condition is used when the inferior just triggered
12885 an exception catchpoint.
12886
12887 The string returned is a newly allocated string that needs to be
12888 deallocated later. */
12889
12890static char *
28010a5d 12891ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12892{
3d0b0fa3
JB
12893 int i;
12894
0963b4bd 12895 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12896 runtime units that have been compiled without debugging info; if
28010a5d 12897 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12898 exception (e.g. "constraint_error") then, during the evaluation
12899 of the condition expression, the symbol lookup on this name would
0963b4bd 12900 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12901 may then be set only on user-defined exceptions which have the
12902 same not-fully-qualified name (e.g. my_package.constraint_error).
12903
12904 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12905 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12906 exception constraint_error" is rewritten into "catch exception
12907 standard.constraint_error".
12908
12909 If an exception named contraint_error is defined in another package of
12910 the inferior program, then the only way to specify this exception as a
12911 breakpoint condition is to use its fully-qualified named:
12912 e.g. my_package.constraint_error. */
12913
12914 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12915 {
28010a5d 12916 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12917 {
12918 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12919 excep_string);
3d0b0fa3
JB
12920 }
12921 }
28010a5d 12922 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12923}
12924
12925/* Return the symtab_and_line that should be used to insert an exception
12926 catchpoint of the TYPE kind.
12927
28010a5d
PA
12928 EXCEP_STRING should contain the name of a specific exception that
12929 the catchpoint should catch, or NULL otherwise.
f7f9143b 12930
28010a5d
PA
12931 ADDR_STRING returns the name of the function where the real
12932 breakpoint that implements the catchpoints is set, depending on the
12933 type of catchpoint we need to create. */
f7f9143b
JB
12934
12935static struct symtab_and_line
761269c8 12936ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12937 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12938{
12939 const char *sym_name;
12940 struct symbol *sym;
f7f9143b 12941
0259addd
JB
12942 /* First, find out which exception support info to use. */
12943 ada_exception_support_info_sniffer ();
12944
12945 /* Then lookup the function on which we will break in order to catch
f7f9143b 12946 the Ada exceptions requested by the user. */
f7f9143b
JB
12947 sym_name = ada_exception_sym_name (ex);
12948 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12949
f17011e0
JB
12950 /* We can assume that SYM is not NULL at this stage. If the symbol
12951 did not exist, ada_exception_support_info_sniffer would have
12952 raised an exception.
f7f9143b 12953
f17011e0
JB
12954 Also, ada_exception_support_info_sniffer should have already
12955 verified that SYM is a function symbol. */
12956 gdb_assert (sym != NULL);
12957 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12958
12959 /* Set ADDR_STRING. */
f7f9143b
JB
12960 *addr_string = xstrdup (sym_name);
12961
f7f9143b 12962 /* Set OPS. */
4b9eee8c 12963 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12964
f17011e0 12965 return find_function_start_sal (sym, 1);
f7f9143b
JB
12966}
12967
b4a5b78b 12968/* Create an Ada exception catchpoint.
f7f9143b 12969
b4a5b78b 12970 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12971
2df4d1d5
JB
12972 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12973 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12974 of the exception to which this catchpoint applies. When not NULL,
12975 the string must be allocated on the heap, and its deallocation
12976 is no longer the responsibility of the caller.
12977
12978 COND_STRING, if not NULL, is the catchpoint condition. This string
12979 must be allocated on the heap, and its deallocation is no longer
12980 the responsibility of the caller.
f7f9143b 12981
b4a5b78b
JB
12982 TEMPFLAG, if nonzero, means that the underlying breakpoint
12983 should be temporary.
28010a5d 12984
b4a5b78b 12985 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12986
349774ef 12987void
28010a5d 12988create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12989 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12990 char *excep_string,
5845583d 12991 char *cond_string,
28010a5d 12992 int tempflag,
349774ef 12993 int disabled,
28010a5d
PA
12994 int from_tty)
12995{
b4a5b78b
JB
12996 char *addr_string = NULL;
12997 const struct breakpoint_ops *ops = NULL;
12998 struct symtab_and_line sal
12999 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d 13000
b270e6f9
TT
13001 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13002 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
349774ef 13003 ops, tempflag, disabled, from_tty);
28010a5d 13004 c->excep_string = excep_string;
b270e6f9 13005 create_excep_cond_exprs (c.get ());
5845583d 13006 if (cond_string != NULL)
b270e6f9
TT
13007 set_breakpoint_condition (c.get (), cond_string, from_tty);
13008 install_breakpoint (0, std::move (c), 1);
f7f9143b
JB
13009}
13010
9ac4176b
PA
13011/* Implement the "catch exception" command. */
13012
13013static void
a121b7c1 13014catch_ada_exception_command (char *arg_entry, int from_tty,
9ac4176b
PA
13015 struct cmd_list_element *command)
13016{
a121b7c1 13017 const char *arg = arg_entry;
9ac4176b
PA
13018 struct gdbarch *gdbarch = get_current_arch ();
13019 int tempflag;
761269c8 13020 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 13021 char *excep_string = NULL;
5845583d 13022 char *cond_string = NULL;
9ac4176b
PA
13023
13024 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13025
13026 if (!arg)
13027 arg = "";
b4a5b78b
JB
13028 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
13029 &cond_string);
13030 create_ada_exception_catchpoint (gdbarch, ex_kind,
13031 excep_string, cond_string,
349774ef
JB
13032 tempflag, 1 /* enabled */,
13033 from_tty);
9ac4176b
PA
13034}
13035
b4a5b78b 13036/* Split the arguments specified in a "catch assert" command.
5845583d 13037
b4a5b78b
JB
13038 ARGS contains the command's arguments (or the empty string if
13039 no arguments were passed).
5845583d
JB
13040
13041 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13042 (the memory needs to be deallocated after use). */
5845583d 13043
b4a5b78b 13044static void
a121b7c1 13045catch_ada_assert_command_split (const char *args, char **cond_string)
f7f9143b 13046{
f1735a53 13047 args = skip_spaces (args);
f7f9143b 13048
5845583d 13049 /* Check whether a condition was provided. */
61012eef 13050 if (startswith (args, "if")
5845583d 13051 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13052 {
5845583d 13053 args += 2;
f1735a53 13054 args = skip_spaces (args);
5845583d
JB
13055 if (args[0] == '\0')
13056 error (_("condition missing after `if' keyword"));
13057 *cond_string = xstrdup (args);
f7f9143b
JB
13058 }
13059
5845583d
JB
13060 /* Otherwise, there should be no other argument at the end of
13061 the command. */
13062 else if (args[0] != '\0')
13063 error (_("Junk at end of arguments."));
f7f9143b
JB
13064}
13065
9ac4176b
PA
13066/* Implement the "catch assert" command. */
13067
13068static void
a121b7c1 13069catch_assert_command (char *arg_entry, int from_tty,
9ac4176b
PA
13070 struct cmd_list_element *command)
13071{
a121b7c1 13072 const char *arg = arg_entry;
9ac4176b
PA
13073 struct gdbarch *gdbarch = get_current_arch ();
13074 int tempflag;
5845583d 13075 char *cond_string = NULL;
9ac4176b
PA
13076
13077 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13078
13079 if (!arg)
13080 arg = "";
b4a5b78b 13081 catch_ada_assert_command_split (arg, &cond_string);
761269c8 13082 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 13083 NULL, cond_string,
349774ef
JB
13084 tempflag, 1 /* enabled */,
13085 from_tty);
9ac4176b 13086}
778865d3
JB
13087
13088/* Return non-zero if the symbol SYM is an Ada exception object. */
13089
13090static int
13091ada_is_exception_sym (struct symbol *sym)
13092{
13093 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13094
13095 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13096 && SYMBOL_CLASS (sym) != LOC_BLOCK
13097 && SYMBOL_CLASS (sym) != LOC_CONST
13098 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13099 && type_name != NULL && strcmp (type_name, "exception") == 0);
13100}
13101
13102/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13103 Ada exception object. This matches all exceptions except the ones
13104 defined by the Ada language. */
13105
13106static int
13107ada_is_non_standard_exception_sym (struct symbol *sym)
13108{
13109 int i;
13110
13111 if (!ada_is_exception_sym (sym))
13112 return 0;
13113
13114 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13115 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13116 return 0; /* A standard exception. */
13117
13118 /* Numeric_Error is also a standard exception, so exclude it.
13119 See the STANDARD_EXC description for more details as to why
13120 this exception is not listed in that array. */
13121 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13122 return 0;
13123
13124 return 1;
13125}
13126
13127/* A helper function for qsort, comparing two struct ada_exc_info
13128 objects.
13129
13130 The comparison is determined first by exception name, and then
13131 by exception address. */
13132
13133static int
13134compare_ada_exception_info (const void *a, const void *b)
13135{
13136 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
13137 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
13138 int result;
13139
13140 result = strcmp (exc_a->name, exc_b->name);
13141 if (result != 0)
13142 return result;
13143
13144 if (exc_a->addr < exc_b->addr)
13145 return -1;
13146 if (exc_a->addr > exc_b->addr)
13147 return 1;
13148
13149 return 0;
13150}
13151
13152/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13153 routine, but keeping the first SKIP elements untouched.
13154
13155 All duplicates are also removed. */
13156
13157static void
13158sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
13159 int skip)
13160{
13161 struct ada_exc_info *to_sort
13162 = VEC_address (ada_exc_info, *exceptions) + skip;
13163 int to_sort_len
13164 = VEC_length (ada_exc_info, *exceptions) - skip;
13165 int i, j;
13166
13167 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
13168 compare_ada_exception_info);
13169
13170 for (i = 1, j = 1; i < to_sort_len; i++)
13171 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
13172 to_sort[j++] = to_sort[i];
13173 to_sort_len = j;
13174 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
13175}
13176
778865d3
JB
13177/* Add all exceptions defined by the Ada standard whose name match
13178 a regular expression.
13179
13180 If PREG is not NULL, then this regexp_t object is used to
13181 perform the symbol name matching. Otherwise, no name-based
13182 filtering is performed.
13183
13184 EXCEPTIONS is a vector of exceptions to which matching exceptions
13185 gets pushed. */
13186
13187static void
2d7cc5c7
PA
13188ada_add_standard_exceptions (compiled_regex *preg,
13189 VEC(ada_exc_info) **exceptions)
778865d3
JB
13190{
13191 int i;
13192
13193 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13194 {
13195 if (preg == NULL
2d7cc5c7 13196 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13197 {
13198 struct bound_minimal_symbol msymbol
13199 = ada_lookup_simple_minsym (standard_exc[i]);
13200
13201 if (msymbol.minsym != NULL)
13202 {
13203 struct ada_exc_info info
77e371c0 13204 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3
JB
13205
13206 VEC_safe_push (ada_exc_info, *exceptions, &info);
13207 }
13208 }
13209 }
13210}
13211
13212/* Add all Ada exceptions defined locally and accessible from the given
13213 FRAME.
13214
13215 If PREG is not NULL, then this regexp_t object is used to
13216 perform the symbol name matching. Otherwise, no name-based
13217 filtering is performed.
13218
13219 EXCEPTIONS is a vector of exceptions to which matching exceptions
13220 gets pushed. */
13221
13222static void
2d7cc5c7
PA
13223ada_add_exceptions_from_frame (compiled_regex *preg,
13224 struct frame_info *frame,
778865d3
JB
13225 VEC(ada_exc_info) **exceptions)
13226{
3977b71f 13227 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13228
13229 while (block != 0)
13230 {
13231 struct block_iterator iter;
13232 struct symbol *sym;
13233
13234 ALL_BLOCK_SYMBOLS (block, iter, sym)
13235 {
13236 switch (SYMBOL_CLASS (sym))
13237 {
13238 case LOC_TYPEDEF:
13239 case LOC_BLOCK:
13240 case LOC_CONST:
13241 break;
13242 default:
13243 if (ada_is_exception_sym (sym))
13244 {
13245 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13246 SYMBOL_VALUE_ADDRESS (sym)};
13247
13248 VEC_safe_push (ada_exc_info, *exceptions, &info);
13249 }
13250 }
13251 }
13252 if (BLOCK_FUNCTION (block) != NULL)
13253 break;
13254 block = BLOCK_SUPERBLOCK (block);
13255 }
13256}
13257
14bc53a8
PA
13258/* Return true if NAME matches PREG or if PREG is NULL. */
13259
13260static bool
2d7cc5c7 13261name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13262{
13263 return (preg == NULL
2d7cc5c7 13264 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13265}
13266
778865d3
JB
13267/* Add all exceptions defined globally whose name name match
13268 a regular expression, excluding standard exceptions.
13269
13270 The reason we exclude standard exceptions is that they need
13271 to be handled separately: Standard exceptions are defined inside
13272 a runtime unit which is normally not compiled with debugging info,
13273 and thus usually do not show up in our symbol search. However,
13274 if the unit was in fact built with debugging info, we need to
13275 exclude them because they would duplicate the entry we found
13276 during the special loop that specifically searches for those
13277 standard exceptions.
13278
13279 If PREG is not NULL, then this regexp_t object is used to
13280 perform the symbol name matching. Otherwise, no name-based
13281 filtering is performed.
13282
13283 EXCEPTIONS is a vector of exceptions to which matching exceptions
13284 gets pushed. */
13285
13286static void
2d7cc5c7
PA
13287ada_add_global_exceptions (compiled_regex *preg,
13288 VEC(ada_exc_info) **exceptions)
778865d3
JB
13289{
13290 struct objfile *objfile;
43f3e411 13291 struct compunit_symtab *s;
778865d3 13292
14bc53a8
PA
13293 /* In Ada, the symbol "search name" is a linkage name, whereas the
13294 regular expression used to do the matching refers to the natural
13295 name. So match against the decoded name. */
13296 expand_symtabs_matching (NULL,
13297 [&] (const char *search_name)
13298 {
13299 const char *decoded = ada_decode (search_name);
13300 return name_matches_regex (decoded, preg);
13301 },
13302 NULL,
13303 VARIABLES_DOMAIN);
778865d3 13304
43f3e411 13305 ALL_COMPUNITS (objfile, s)
778865d3 13306 {
43f3e411 13307 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13308 int i;
13309
13310 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13311 {
13312 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13313 struct block_iterator iter;
13314 struct symbol *sym;
13315
13316 ALL_BLOCK_SYMBOLS (b, iter, sym)
13317 if (ada_is_non_standard_exception_sym (sym)
14bc53a8 13318 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
778865d3
JB
13319 {
13320 struct ada_exc_info info
13321 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13322
13323 VEC_safe_push (ada_exc_info, *exceptions, &info);
13324 }
13325 }
13326 }
13327}
13328
13329/* Implements ada_exceptions_list with the regular expression passed
13330 as a regex_t, rather than a string.
13331
13332 If not NULL, PREG is used to filter out exceptions whose names
13333 do not match. Otherwise, all exceptions are listed. */
13334
13335static VEC(ada_exc_info) *
2d7cc5c7 13336ada_exceptions_list_1 (compiled_regex *preg)
778865d3
JB
13337{
13338 VEC(ada_exc_info) *result = NULL;
13339 struct cleanup *old_chain
13340 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
13341 int prev_len;
13342
13343 /* First, list the known standard exceptions. These exceptions
13344 need to be handled separately, as they are usually defined in
13345 runtime units that have been compiled without debugging info. */
13346
13347 ada_add_standard_exceptions (preg, &result);
13348
13349 /* Next, find all exceptions whose scope is local and accessible
13350 from the currently selected frame. */
13351
13352 if (has_stack_frames ())
13353 {
13354 prev_len = VEC_length (ada_exc_info, result);
13355 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13356 &result);
13357 if (VEC_length (ada_exc_info, result) > prev_len)
13358 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13359 }
13360
13361 /* Add all exceptions whose scope is global. */
13362
13363 prev_len = VEC_length (ada_exc_info, result);
13364 ada_add_global_exceptions (preg, &result);
13365 if (VEC_length (ada_exc_info, result) > prev_len)
13366 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13367
13368 discard_cleanups (old_chain);
13369 return result;
13370}
13371
13372/* Return a vector of ada_exc_info.
13373
13374 If REGEXP is NULL, all exceptions are included in the result.
13375 Otherwise, it should contain a valid regular expression,
13376 and only the exceptions whose names match that regular expression
13377 are included in the result.
13378
13379 The exceptions are sorted in the following order:
13380 - Standard exceptions (defined by the Ada language), in
13381 alphabetical order;
13382 - Exceptions only visible from the current frame, in
13383 alphabetical order;
13384 - Exceptions whose scope is global, in alphabetical order. */
13385
13386VEC(ada_exc_info) *
13387ada_exceptions_list (const char *regexp)
13388{
2d7cc5c7
PA
13389 if (regexp == NULL)
13390 return ada_exceptions_list_1 (NULL);
778865d3 13391
2d7cc5c7
PA
13392 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13393 return ada_exceptions_list_1 (&reg);
778865d3
JB
13394}
13395
13396/* Implement the "info exceptions" command. */
13397
13398static void
13399info_exceptions_command (char *regexp, int from_tty)
13400{
13401 VEC(ada_exc_info) *exceptions;
13402 struct cleanup *cleanup;
13403 struct gdbarch *gdbarch = get_current_arch ();
13404 int ix;
13405 struct ada_exc_info *info;
13406
13407 exceptions = ada_exceptions_list (regexp);
13408 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
13409
13410 if (regexp != NULL)
13411 printf_filtered
13412 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13413 else
13414 printf_filtered (_("All defined Ada exceptions:\n"));
13415
13416 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
13417 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
13418
13419 do_cleanups (cleanup);
13420}
13421
4c4b4cd2
PH
13422 /* Operators */
13423/* Information about operators given special treatment in functions
13424 below. */
13425/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13426
13427#define ADA_OPERATORS \
13428 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13429 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13430 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13431 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13432 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13433 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13434 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13435 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13436 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13437 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13438 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13439 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13440 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13441 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13442 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13443 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13444 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13445 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13446 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13447
13448static void
554794dc
SDJ
13449ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13450 int *argsp)
4c4b4cd2
PH
13451{
13452 switch (exp->elts[pc - 1].opcode)
13453 {
76a01679 13454 default:
4c4b4cd2
PH
13455 operator_length_standard (exp, pc, oplenp, argsp);
13456 break;
13457
13458#define OP_DEFN(op, len, args, binop) \
13459 case op: *oplenp = len; *argsp = args; break;
13460 ADA_OPERATORS;
13461#undef OP_DEFN
52ce6436
PH
13462
13463 case OP_AGGREGATE:
13464 *oplenp = 3;
13465 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13466 break;
13467
13468 case OP_CHOICES:
13469 *oplenp = 3;
13470 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13471 break;
4c4b4cd2
PH
13472 }
13473}
13474
c0201579
JK
13475/* Implementation of the exp_descriptor method operator_check. */
13476
13477static int
13478ada_operator_check (struct expression *exp, int pos,
13479 int (*objfile_func) (struct objfile *objfile, void *data),
13480 void *data)
13481{
13482 const union exp_element *const elts = exp->elts;
13483 struct type *type = NULL;
13484
13485 switch (elts[pos].opcode)
13486 {
13487 case UNOP_IN_RANGE:
13488 case UNOP_QUAL:
13489 type = elts[pos + 1].type;
13490 break;
13491
13492 default:
13493 return operator_check_standard (exp, pos, objfile_func, data);
13494 }
13495
13496 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13497
13498 if (type && TYPE_OBJFILE (type)
13499 && (*objfile_func) (TYPE_OBJFILE (type), data))
13500 return 1;
13501
13502 return 0;
13503}
13504
a121b7c1 13505static const char *
4c4b4cd2
PH
13506ada_op_name (enum exp_opcode opcode)
13507{
13508 switch (opcode)
13509 {
76a01679 13510 default:
4c4b4cd2 13511 return op_name_standard (opcode);
52ce6436 13512
4c4b4cd2
PH
13513#define OP_DEFN(op, len, args, binop) case op: return #op;
13514 ADA_OPERATORS;
13515#undef OP_DEFN
52ce6436
PH
13516
13517 case OP_AGGREGATE:
13518 return "OP_AGGREGATE";
13519 case OP_CHOICES:
13520 return "OP_CHOICES";
13521 case OP_NAME:
13522 return "OP_NAME";
4c4b4cd2
PH
13523 }
13524}
13525
13526/* As for operator_length, but assumes PC is pointing at the first
13527 element of the operator, and gives meaningful results only for the
52ce6436 13528 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13529
13530static void
76a01679
JB
13531ada_forward_operator_length (struct expression *exp, int pc,
13532 int *oplenp, int *argsp)
4c4b4cd2 13533{
76a01679 13534 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13535 {
13536 default:
13537 *oplenp = *argsp = 0;
13538 break;
52ce6436 13539
4c4b4cd2
PH
13540#define OP_DEFN(op, len, args, binop) \
13541 case op: *oplenp = len; *argsp = args; break;
13542 ADA_OPERATORS;
13543#undef OP_DEFN
52ce6436
PH
13544
13545 case OP_AGGREGATE:
13546 *oplenp = 3;
13547 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13548 break;
13549
13550 case OP_CHOICES:
13551 *oplenp = 3;
13552 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13553 break;
13554
13555 case OP_STRING:
13556 case OP_NAME:
13557 {
13558 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13559
52ce6436
PH
13560 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13561 *argsp = 0;
13562 break;
13563 }
4c4b4cd2
PH
13564 }
13565}
13566
13567static int
13568ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13569{
13570 enum exp_opcode op = exp->elts[elt].opcode;
13571 int oplen, nargs;
13572 int pc = elt;
13573 int i;
76a01679 13574
4c4b4cd2
PH
13575 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13576
76a01679 13577 switch (op)
4c4b4cd2 13578 {
76a01679 13579 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13580 case OP_ATR_FIRST:
13581 case OP_ATR_LAST:
13582 case OP_ATR_LENGTH:
13583 case OP_ATR_IMAGE:
13584 case OP_ATR_MAX:
13585 case OP_ATR_MIN:
13586 case OP_ATR_MODULUS:
13587 case OP_ATR_POS:
13588 case OP_ATR_SIZE:
13589 case OP_ATR_TAG:
13590 case OP_ATR_VAL:
13591 break;
13592
13593 case UNOP_IN_RANGE:
13594 case UNOP_QUAL:
323e0a4a
AC
13595 /* XXX: gdb_sprint_host_address, type_sprint */
13596 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13597 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13598 fprintf_filtered (stream, " (");
13599 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13600 fprintf_filtered (stream, ")");
13601 break;
13602 case BINOP_IN_BOUNDS:
52ce6436
PH
13603 fprintf_filtered (stream, " (%d)",
13604 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13605 break;
13606 case TERNOP_IN_RANGE:
13607 break;
13608
52ce6436
PH
13609 case OP_AGGREGATE:
13610 case OP_OTHERS:
13611 case OP_DISCRETE_RANGE:
13612 case OP_POSITIONAL:
13613 case OP_CHOICES:
13614 break;
13615
13616 case OP_NAME:
13617 case OP_STRING:
13618 {
13619 char *name = &exp->elts[elt + 2].string;
13620 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13621
52ce6436
PH
13622 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13623 break;
13624 }
13625
4c4b4cd2
PH
13626 default:
13627 return dump_subexp_body_standard (exp, stream, elt);
13628 }
13629
13630 elt += oplen;
13631 for (i = 0; i < nargs; i += 1)
13632 elt = dump_subexp (exp, stream, elt);
13633
13634 return elt;
13635}
13636
13637/* The Ada extension of print_subexp (q.v.). */
13638
76a01679
JB
13639static void
13640ada_print_subexp (struct expression *exp, int *pos,
13641 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13642{
52ce6436 13643 int oplen, nargs, i;
4c4b4cd2
PH
13644 int pc = *pos;
13645 enum exp_opcode op = exp->elts[pc].opcode;
13646
13647 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13648
52ce6436 13649 *pos += oplen;
4c4b4cd2
PH
13650 switch (op)
13651 {
13652 default:
52ce6436 13653 *pos -= oplen;
4c4b4cd2
PH
13654 print_subexp_standard (exp, pos, stream, prec);
13655 return;
13656
13657 case OP_VAR_VALUE:
4c4b4cd2
PH
13658 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13659 return;
13660
13661 case BINOP_IN_BOUNDS:
323e0a4a 13662 /* XXX: sprint_subexp */
4c4b4cd2 13663 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13664 fputs_filtered (" in ", stream);
4c4b4cd2 13665 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13666 fputs_filtered ("'range", stream);
4c4b4cd2 13667 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13668 fprintf_filtered (stream, "(%ld)",
13669 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13670 return;
13671
13672 case TERNOP_IN_RANGE:
4c4b4cd2 13673 if (prec >= PREC_EQUAL)
76a01679 13674 fputs_filtered ("(", stream);
323e0a4a 13675 /* XXX: sprint_subexp */
4c4b4cd2 13676 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13677 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13678 print_subexp (exp, pos, stream, PREC_EQUAL);
13679 fputs_filtered (" .. ", stream);
13680 print_subexp (exp, pos, stream, PREC_EQUAL);
13681 if (prec >= PREC_EQUAL)
76a01679
JB
13682 fputs_filtered (")", stream);
13683 return;
4c4b4cd2
PH
13684
13685 case OP_ATR_FIRST:
13686 case OP_ATR_LAST:
13687 case OP_ATR_LENGTH:
13688 case OP_ATR_IMAGE:
13689 case OP_ATR_MAX:
13690 case OP_ATR_MIN:
13691 case OP_ATR_MODULUS:
13692 case OP_ATR_POS:
13693 case OP_ATR_SIZE:
13694 case OP_ATR_TAG:
13695 case OP_ATR_VAL:
4c4b4cd2 13696 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13697 {
13698 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13699 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13700 &type_print_raw_options);
76a01679
JB
13701 *pos += 3;
13702 }
4c4b4cd2 13703 else
76a01679 13704 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13705 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13706 if (nargs > 1)
76a01679
JB
13707 {
13708 int tem;
5b4ee69b 13709
76a01679
JB
13710 for (tem = 1; tem < nargs; tem += 1)
13711 {
13712 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13713 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13714 }
13715 fputs_filtered (")", stream);
13716 }
4c4b4cd2 13717 return;
14f9c5c9 13718
4c4b4cd2 13719 case UNOP_QUAL:
4c4b4cd2
PH
13720 type_print (exp->elts[pc + 1].type, "", stream, 0);
13721 fputs_filtered ("'(", stream);
13722 print_subexp (exp, pos, stream, PREC_PREFIX);
13723 fputs_filtered (")", stream);
13724 return;
14f9c5c9 13725
4c4b4cd2 13726 case UNOP_IN_RANGE:
323e0a4a 13727 /* XXX: sprint_subexp */
4c4b4cd2 13728 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13729 fputs_filtered (" in ", stream);
79d43c61
TT
13730 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13731 &type_print_raw_options);
4c4b4cd2 13732 return;
52ce6436
PH
13733
13734 case OP_DISCRETE_RANGE:
13735 print_subexp (exp, pos, stream, PREC_SUFFIX);
13736 fputs_filtered ("..", stream);
13737 print_subexp (exp, pos, stream, PREC_SUFFIX);
13738 return;
13739
13740 case OP_OTHERS:
13741 fputs_filtered ("others => ", stream);
13742 print_subexp (exp, pos, stream, PREC_SUFFIX);
13743 return;
13744
13745 case OP_CHOICES:
13746 for (i = 0; i < nargs-1; i += 1)
13747 {
13748 if (i > 0)
13749 fputs_filtered ("|", stream);
13750 print_subexp (exp, pos, stream, PREC_SUFFIX);
13751 }
13752 fputs_filtered (" => ", stream);
13753 print_subexp (exp, pos, stream, PREC_SUFFIX);
13754 return;
13755
13756 case OP_POSITIONAL:
13757 print_subexp (exp, pos, stream, PREC_SUFFIX);
13758 return;
13759
13760 case OP_AGGREGATE:
13761 fputs_filtered ("(", stream);
13762 for (i = 0; i < nargs; i += 1)
13763 {
13764 if (i > 0)
13765 fputs_filtered (", ", stream);
13766 print_subexp (exp, pos, stream, PREC_SUFFIX);
13767 }
13768 fputs_filtered (")", stream);
13769 return;
4c4b4cd2
PH
13770 }
13771}
14f9c5c9
AS
13772
13773/* Table mapping opcodes into strings for printing operators
13774 and precedences of the operators. */
13775
d2e4a39e
AS
13776static const struct op_print ada_op_print_tab[] = {
13777 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13778 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13779 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13780 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13781 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13782 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13783 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13784 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13785 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13786 {">=", BINOP_GEQ, PREC_ORDER, 0},
13787 {">", BINOP_GTR, PREC_ORDER, 0},
13788 {"<", BINOP_LESS, PREC_ORDER, 0},
13789 {">>", BINOP_RSH, PREC_SHIFT, 0},
13790 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13791 {"+", BINOP_ADD, PREC_ADD, 0},
13792 {"-", BINOP_SUB, PREC_ADD, 0},
13793 {"&", BINOP_CONCAT, PREC_ADD, 0},
13794 {"*", BINOP_MUL, PREC_MUL, 0},
13795 {"/", BINOP_DIV, PREC_MUL, 0},
13796 {"rem", BINOP_REM, PREC_MUL, 0},
13797 {"mod", BINOP_MOD, PREC_MUL, 0},
13798 {"**", BINOP_EXP, PREC_REPEAT, 0},
13799 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13800 {"-", UNOP_NEG, PREC_PREFIX, 0},
13801 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13802 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13803 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13804 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13805 {".all", UNOP_IND, PREC_SUFFIX, 1},
13806 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13807 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 13808 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
13809};
13810\f
72d5681a
PH
13811enum ada_primitive_types {
13812 ada_primitive_type_int,
13813 ada_primitive_type_long,
13814 ada_primitive_type_short,
13815 ada_primitive_type_char,
13816 ada_primitive_type_float,
13817 ada_primitive_type_double,
13818 ada_primitive_type_void,
13819 ada_primitive_type_long_long,
13820 ada_primitive_type_long_double,
13821 ada_primitive_type_natural,
13822 ada_primitive_type_positive,
13823 ada_primitive_type_system_address,
13824 nr_ada_primitive_types
13825};
6c038f32
PH
13826
13827static void
d4a9a881 13828ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13829 struct language_arch_info *lai)
13830{
d4a9a881 13831 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13832
72d5681a 13833 lai->primitive_type_vector
d4a9a881 13834 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13835 struct type *);
e9bb382b
UW
13836
13837 lai->primitive_type_vector [ada_primitive_type_int]
13838 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13839 0, "integer");
13840 lai->primitive_type_vector [ada_primitive_type_long]
13841 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13842 0, "long_integer");
13843 lai->primitive_type_vector [ada_primitive_type_short]
13844 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13845 0, "short_integer");
13846 lai->string_char_type
13847 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 13848 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
13849 lai->primitive_type_vector [ada_primitive_type_float]
13850 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 13851 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
13852 lai->primitive_type_vector [ada_primitive_type_double]
13853 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 13854 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
13855 lai->primitive_type_vector [ada_primitive_type_long_long]
13856 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13857 0, "long_long_integer");
13858 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 13859 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 13860 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
13861 lai->primitive_type_vector [ada_primitive_type_natural]
13862 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13863 0, "natural");
13864 lai->primitive_type_vector [ada_primitive_type_positive]
13865 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13866 0, "positive");
13867 lai->primitive_type_vector [ada_primitive_type_void]
13868 = builtin->builtin_void;
13869
13870 lai->primitive_type_vector [ada_primitive_type_system_address]
13871 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13872 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13873 = "system__address";
fbb06eb1 13874
47e729a8 13875 lai->bool_type_symbol = NULL;
fbb06eb1 13876 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13877}
6c038f32
PH
13878\f
13879 /* Language vector */
13880
13881/* Not really used, but needed in the ada_language_defn. */
13882
13883static void
6c7a06a3 13884emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13885{
6c7a06a3 13886 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13887}
13888
13889static int
410a0ff2 13890parse (struct parser_state *ps)
6c038f32
PH
13891{
13892 warnings_issued = 0;
410a0ff2 13893 return ada_parse (ps);
6c038f32
PH
13894}
13895
13896static const struct exp_descriptor ada_exp_descriptor = {
13897 ada_print_subexp,
13898 ada_operator_length,
c0201579 13899 ada_operator_check,
6c038f32
PH
13900 ada_op_name,
13901 ada_dump_subexp_body,
13902 ada_evaluate_subexp
13903};
13904
1a119f36 13905/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13906 for Ada. */
13907
1a119f36
JB
13908static symbol_name_cmp_ftype
13909ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13910{
13911 if (should_use_wild_match (lookup_name))
13912 return wild_match;
13913 else
13914 return compare_names;
13915}
13916
a5ee536b
JB
13917/* Implement the "la_read_var_value" language_defn method for Ada. */
13918
13919static struct value *
63e43d3a
PMR
13920ada_read_var_value (struct symbol *var, const struct block *var_block,
13921 struct frame_info *frame)
a5ee536b 13922{
3977b71f 13923 const struct block *frame_block = NULL;
a5ee536b
JB
13924 struct symbol *renaming_sym = NULL;
13925
13926 /* The only case where default_read_var_value is not sufficient
13927 is when VAR is a renaming... */
13928 if (frame)
13929 frame_block = get_frame_block (frame, NULL);
13930 if (frame_block)
13931 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13932 if (renaming_sym != NULL)
13933 return ada_read_renaming_var_value (renaming_sym, frame_block);
13934
13935 /* This is a typical case where we expect the default_read_var_value
13936 function to work. */
63e43d3a 13937 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
13938}
13939
56618e20
TT
13940static const char *ada_extensions[] =
13941{
13942 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13943};
13944
47e77640 13945extern const struct language_defn ada_language_defn = {
6c038f32 13946 "ada", /* Language name */
6abde28f 13947 "Ada",
6c038f32 13948 language_ada,
6c038f32 13949 range_check_off,
6c038f32
PH
13950 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13951 that's not quite what this means. */
6c038f32 13952 array_row_major,
9a044a89 13953 macro_expansion_no,
56618e20 13954 ada_extensions,
6c038f32
PH
13955 &ada_exp_descriptor,
13956 parse,
b3f11165 13957 ada_yyerror,
6c038f32
PH
13958 resolve,
13959 ada_printchar, /* Print a character constant */
13960 ada_printstr, /* Function to print string constant */
13961 emit_char, /* Function to print single char (not used) */
6c038f32 13962 ada_print_type, /* Print a type using appropriate syntax */
be942545 13963 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13964 ada_val_print, /* Print a value using appropriate syntax */
13965 ada_value_print, /* Print a top-level value */
a5ee536b 13966 ada_read_var_value, /* la_read_var_value */
6c038f32 13967 NULL, /* Language specific skip_trampoline */
2b2d9e11 13968 NULL, /* name_of_this */
6c038f32
PH
13969 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13970 basic_lookup_transparent_type, /* lookup_transparent_type */
13971 ada_la_decode, /* Language specific symbol demangler */
8b302db8 13972 ada_sniff_from_mangled_name,
0963b4bd
MS
13973 NULL, /* Language specific
13974 class_name_from_physname */
6c038f32
PH
13975 ada_op_print_tab, /* expression operators for printing */
13976 0, /* c-style arrays */
13977 1, /* String lower bound */
6c038f32 13978 ada_get_gdb_completer_word_break_characters,
eb3ff9a5 13979 ada_collect_symbol_completion_matches,
72d5681a 13980 ada_language_arch_info,
e79af960 13981 ada_print_array_index,
41f1b697 13982 default_pass_by_reference,
ae6a3a4c 13983 c_get_string,
43cc5389 13984 c_watch_location_expression,
1a119f36 13985 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13986 ada_iterate_over_symbols,
a53b64ea 13987 &ada_varobj_ops,
bb2ec1b3
TT
13988 NULL,
13989 NULL,
6c038f32
PH
13990 LANG_MAGIC
13991};
13992
5bf03f13
JB
13993/* Command-list for the "set/show ada" prefix command. */
13994static struct cmd_list_element *set_ada_list;
13995static struct cmd_list_element *show_ada_list;
13996
13997/* Implement the "set ada" prefix command. */
13998
13999static void
14000set_ada_command (char *arg, int from_tty)
14001{
14002 printf_unfiltered (_(\
14003"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14004 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14005}
14006
14007/* Implement the "show ada" prefix command. */
14008
14009static void
14010show_ada_command (char *args, int from_tty)
14011{
14012 cmd_show_list (show_ada_list, from_tty, "");
14013}
14014
2060206e
PA
14015static void
14016initialize_ada_catchpoint_ops (void)
14017{
14018 struct breakpoint_ops *ops;
14019
14020 initialize_breakpoint_ops ();
14021
14022 ops = &catch_exception_breakpoint_ops;
14023 *ops = bkpt_breakpoint_ops;
2060206e
PA
14024 ops->allocate_location = allocate_location_catch_exception;
14025 ops->re_set = re_set_catch_exception;
14026 ops->check_status = check_status_catch_exception;
14027 ops->print_it = print_it_catch_exception;
14028 ops->print_one = print_one_catch_exception;
14029 ops->print_mention = print_mention_catch_exception;
14030 ops->print_recreate = print_recreate_catch_exception;
14031
14032 ops = &catch_exception_unhandled_breakpoint_ops;
14033 *ops = bkpt_breakpoint_ops;
2060206e
PA
14034 ops->allocate_location = allocate_location_catch_exception_unhandled;
14035 ops->re_set = re_set_catch_exception_unhandled;
14036 ops->check_status = check_status_catch_exception_unhandled;
14037 ops->print_it = print_it_catch_exception_unhandled;
14038 ops->print_one = print_one_catch_exception_unhandled;
14039 ops->print_mention = print_mention_catch_exception_unhandled;
14040 ops->print_recreate = print_recreate_catch_exception_unhandled;
14041
14042 ops = &catch_assert_breakpoint_ops;
14043 *ops = bkpt_breakpoint_ops;
2060206e
PA
14044 ops->allocate_location = allocate_location_catch_assert;
14045 ops->re_set = re_set_catch_assert;
14046 ops->check_status = check_status_catch_assert;
14047 ops->print_it = print_it_catch_assert;
14048 ops->print_one = print_one_catch_assert;
14049 ops->print_mention = print_mention_catch_assert;
14050 ops->print_recreate = print_recreate_catch_assert;
14051}
14052
3d9434b5
JB
14053/* This module's 'new_objfile' observer. */
14054
14055static void
14056ada_new_objfile_observer (struct objfile *objfile)
14057{
14058 ada_clear_symbol_cache ();
14059}
14060
14061/* This module's 'free_objfile' observer. */
14062
14063static void
14064ada_free_objfile_observer (struct objfile *objfile)
14065{
14066 ada_clear_symbol_cache ();
14067}
14068
d2e4a39e 14069void
6c038f32 14070_initialize_ada_language (void)
14f9c5c9 14071{
2060206e
PA
14072 initialize_ada_catchpoint_ops ();
14073
5bf03f13
JB
14074 add_prefix_cmd ("ada", no_class, set_ada_command,
14075 _("Prefix command for changing Ada-specfic settings"),
14076 &set_ada_list, "set ada ", 0, &setlist);
14077
14078 add_prefix_cmd ("ada", no_class, show_ada_command,
14079 _("Generic command for showing Ada-specific settings."),
14080 &show_ada_list, "show ada ", 0, &showlist);
14081
14082 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14083 &trust_pad_over_xvs, _("\
14084Enable or disable an optimization trusting PAD types over XVS types"), _("\
14085Show whether an optimization trusting PAD types over XVS types is activated"),
14086 _("\
14087This is related to the encoding used by the GNAT compiler. The debugger\n\
14088should normally trust the contents of PAD types, but certain older versions\n\
14089of GNAT have a bug that sometimes causes the information in the PAD type\n\
14090to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14091work around this bug. It is always safe to turn this option \"off\", but\n\
14092this incurs a slight performance penalty, so it is recommended to NOT change\n\
14093this option to \"off\" unless necessary."),
14094 NULL, NULL, &set_ada_list, &show_ada_list);
14095
d72413e6
PMR
14096 add_setshow_boolean_cmd ("print-signatures", class_vars,
14097 &print_signatures, _("\
14098Enable or disable the output of formal and return types for functions in the \
14099overloads selection menu"), _("\
14100Show whether the output of formal and return types for functions in the \
14101overloads selection menu is activated"),
14102 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14103
9ac4176b
PA
14104 add_catch_command ("exception", _("\
14105Catch Ada exceptions, when raised.\n\
14106With an argument, catch only exceptions with the given name."),
14107 catch_ada_exception_command,
14108 NULL,
14109 CATCH_PERMANENT,
14110 CATCH_TEMPORARY);
14111 add_catch_command ("assert", _("\
14112Catch failed Ada assertions, when raised.\n\
14113With an argument, catch only exceptions with the given name."),
14114 catch_assert_command,
14115 NULL,
14116 CATCH_PERMANENT,
14117 CATCH_TEMPORARY);
14118
6c038f32 14119 varsize_limit = 65536;
6c038f32 14120
778865d3
JB
14121 add_info ("exceptions", info_exceptions_command,
14122 _("\
14123List all Ada exception names.\n\
14124If a regular expression is passed as an argument, only those matching\n\
14125the regular expression are listed."));
14126
c6044dd1
JB
14127 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14128 _("Set Ada maintenance-related variables."),
14129 &maint_set_ada_cmdlist, "maintenance set ada ",
14130 0/*allow-unknown*/, &maintenance_set_cmdlist);
14131
14132 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14133 _("Show Ada maintenance-related variables"),
14134 &maint_show_ada_cmdlist, "maintenance show ada ",
14135 0/*allow-unknown*/, &maintenance_show_cmdlist);
14136
14137 add_setshow_boolean_cmd
14138 ("ignore-descriptive-types", class_maintenance,
14139 &ada_ignore_descriptive_types_p,
14140 _("Set whether descriptive types generated by GNAT should be ignored."),
14141 _("Show whether descriptive types generated by GNAT should be ignored."),
14142 _("\
14143When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14144DWARF attribute."),
14145 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14146
6c038f32
PH
14147 obstack_init (&symbol_list_obstack);
14148
14149 decoded_names_store = htab_create_alloc
14150 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
14151 NULL, xcalloc, xfree);
6b69afc4 14152
3d9434b5
JB
14153 /* The ada-lang observers. */
14154 observer_attach_new_objfile (ada_new_objfile_observer);
14155 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 14156 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
14157
14158 /* Setup various context-specific data. */
e802dbe0 14159 ada_inferior_data
8e260fc0 14160 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14161 ada_pspace_data_handle
14162 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14163}