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