]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
[opcodes][arm] Remove bogus entry added by accident in former patch
[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"
ccefe4c4 64
4c4b4cd2 65/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 66 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
67 Copied from valarith.c. */
68
69#ifndef TRUNCATION_TOWARDS_ZERO
70#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
71#endif
72
d2e4a39e 73static struct type *desc_base_type (struct type *);
14f9c5c9 74
d2e4a39e 75static struct type *desc_bounds_type (struct type *);
14f9c5c9 76
d2e4a39e 77static struct value *desc_bounds (struct value *);
14f9c5c9 78
d2e4a39e 79static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 80
d2e4a39e 81static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 82
556bdfd4 83static struct type *desc_data_target_type (struct type *);
14f9c5c9 84
d2e4a39e 85static struct value *desc_data (struct value *);
14f9c5c9 86
d2e4a39e 87static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 88
d2e4a39e 89static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 90
d2e4a39e 91static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 92
d2e4a39e 93static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 94
d2e4a39e 95static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 96
d2e4a39e 97static struct type *desc_index_type (struct type *, int);
14f9c5c9 98
d2e4a39e 99static int desc_arity (struct type *);
14f9c5c9 100
d2e4a39e 101static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 102
d2e4a39e 103static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 104
40658b94
PH
105static int full_match (const char *, const char *);
106
40bc484c 107static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 108
4c4b4cd2 109static void ada_add_block_symbols (struct obstack *,
f0c5f9b2 110 const struct block *, const char *,
2570f2b7 111 domain_enum, struct objfile *, int);
14f9c5c9 112
22cee43f
PMR
113static void ada_add_all_symbols (struct obstack *, const struct block *,
114 const char *, domain_enum, int, int *);
115
d12307c1 116static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 117
76a01679 118static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 119 const struct block *);
14f9c5c9 120
4c4b4cd2
PH
121static int num_defns_collected (struct obstack *);
122
d12307c1 123static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 124
4c4b4cd2 125static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 126 struct type *);
14f9c5c9 127
d2e4a39e 128static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 129 struct symbol *, const struct block *);
14f9c5c9 130
d2e4a39e 131static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 132
a121b7c1 133static const char *ada_op_name (enum exp_opcode);
4c4b4cd2
PH
134
135static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 136
d2e4a39e 137static int numeric_type_p (struct type *);
14f9c5c9 138
d2e4a39e 139static int integer_type_p (struct type *);
14f9c5c9 140
d2e4a39e 141static int scalar_type_p (struct type *);
14f9c5c9 142
d2e4a39e 143static int discrete_type_p (struct type *);
14f9c5c9 144
aeb5907d
JB
145static enum ada_renaming_category parse_old_style_renaming (struct type *,
146 const char **,
147 int *,
148 const char **);
149
150static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 151 const struct block *);
aeb5907d 152
a121b7c1 153static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
76a01679 154 int, int, int *);
4c4b4cd2 155
d2e4a39e 156static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 157
b4ba55a1
JB
158static struct type *ada_find_parallel_type_with_name (struct type *,
159 const char *);
160
d2e4a39e 161static int is_dynamic_field (struct type *, int);
14f9c5c9 162
10a2c479 163static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 164 const gdb_byte *,
4c4b4cd2
PH
165 CORE_ADDR, struct value *);
166
167static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 168
28c85d6c 169static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 170
d2e4a39e 171static struct type *to_static_fixed_type (struct type *);
f192137b 172static struct type *static_unwrap_type (struct type *type);
14f9c5c9 173
d2e4a39e 174static struct value *unwrap_value (struct value *);
14f9c5c9 175
ad82864c 176static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 177
ad82864c 178static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 179
ad82864c
JB
180static long decode_packed_array_bitsize (struct type *);
181
182static struct value *decode_constrained_packed_array (struct value *);
183
184static int ada_is_packed_array_type (struct type *);
185
186static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 187
d2e4a39e 188static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 189 struct value **);
14f9c5c9 190
50810684 191static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 192
4c4b4cd2
PH
193static struct value *coerce_unspec_val_to_type (struct value *,
194 struct type *);
14f9c5c9 195
d2e4a39e 196static struct value *get_var_value (char *, char *);
14f9c5c9 197
d2e4a39e 198static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 199
d2e4a39e 200static int equiv_types (struct type *, struct type *);
14f9c5c9 201
d2e4a39e 202static int is_name_suffix (const char *);
14f9c5c9 203
73589123
PH
204static int advance_wild_match (const char **, const char *, int);
205
206static int wild_match (const char *, const char *);
14f9c5c9 207
d2e4a39e 208static struct value *ada_coerce_ref (struct value *);
14f9c5c9 209
4c4b4cd2
PH
210static LONGEST pos_atr (struct value *);
211
3cb382c9 212static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 213
d2e4a39e 214static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 215
4c4b4cd2
PH
216static struct symbol *standard_lookup (const char *, const struct block *,
217 domain_enum);
14f9c5c9 218
108d56a4 219static struct value *ada_search_struct_field (const char *, struct value *, int,
4c4b4cd2
PH
220 struct type *);
221
222static struct value *ada_value_primitive_field (struct value *, int, int,
223 struct type *);
224
0d5cff50 225static int find_struct_field (const char *, struct type *, int,
52ce6436 226 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
227
228static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
229 struct value *);
230
d12307c1 231static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
232 struct value **, int, const char *,
233 struct type *);
234
4c4b4cd2
PH
235static int ada_is_direct_array_type (struct type *);
236
72d5681a
PH
237static void ada_language_arch_info (struct gdbarch *,
238 struct language_arch_info *);
714e53ab 239
52ce6436
PH
240static struct value *ada_index_struct_field (int, struct value *, int,
241 struct type *);
242
243static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
244 struct expression *,
245 int *, enum noside);
52ce6436
PH
246
247static void aggregate_assign_from_choices (struct value *, struct value *,
248 struct expression *,
249 int *, LONGEST *, int *,
250 int, LONGEST, LONGEST);
251
252static void aggregate_assign_positional (struct value *, struct value *,
253 struct expression *,
254 int *, LONGEST *, int *, int,
255 LONGEST, LONGEST);
256
257
258static void aggregate_assign_others (struct value *, struct value *,
259 struct expression *,
260 int *, LONGEST *, int, LONGEST, LONGEST);
261
262
263static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
264
265
266static struct value *ada_evaluate_subexp (struct type *, struct expression *,
267 int *, enum noside);
268
269static void ada_forward_operator_length (struct expression *, int, int *,
270 int *);
852dff6c
JB
271
272static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
273\f
274
ee01b665
JB
275/* The result of a symbol lookup to be stored in our symbol cache. */
276
277struct cache_entry
278{
279 /* The name used to perform the lookup. */
280 const char *name;
281 /* The namespace used during the lookup. */
fe978cb0 282 domain_enum domain;
ee01b665
JB
283 /* The symbol returned by the lookup, or NULL if no matching symbol
284 was found. */
285 struct symbol *sym;
286 /* The block where the symbol was found, or NULL if no matching
287 symbol was found. */
288 const struct block *block;
289 /* A pointer to the next entry with the same hash. */
290 struct cache_entry *next;
291};
292
293/* The Ada symbol cache, used to store the result of Ada-mode symbol
294 lookups in the course of executing the user's commands.
295
296 The cache is implemented using a simple, fixed-sized hash.
297 The size is fixed on the grounds that there are not likely to be
298 all that many symbols looked up during any given session, regardless
299 of the size of the symbol table. If we decide to go to a resizable
300 table, let's just use the stuff from libiberty instead. */
301
302#define HASH_SIZE 1009
303
304struct ada_symbol_cache
305{
306 /* An obstack used to store the entries in our cache. */
307 struct obstack cache_space;
308
309 /* The root of the hash table used to implement our symbol cache. */
310 struct cache_entry *root[HASH_SIZE];
311};
312
313static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 314
4c4b4cd2 315/* Maximum-sized dynamic type. */
14f9c5c9
AS
316static unsigned int varsize_limit;
317
67cb5b2d 318static const char ada_completer_word_break_characters[] =
4c4b4cd2
PH
319#ifdef VMS
320 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
321#else
14f9c5c9 322 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 323#endif
14f9c5c9 324
4c4b4cd2 325/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 326static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 327 = "__gnat_ada_main_program_name";
14f9c5c9 328
4c4b4cd2
PH
329/* Limit on the number of warnings to raise per expression evaluation. */
330static int warning_limit = 2;
331
332/* Number of warning messages issued; reset to 0 by cleanups after
333 expression evaluation. */
334static int warnings_issued = 0;
335
336static const char *known_runtime_file_name_patterns[] = {
337 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
338};
339
340static const char *known_auxiliary_function_name_patterns[] = {
341 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
342};
343
344/* Space for allocating results of ada_lookup_symbol_list. */
345static struct obstack symbol_list_obstack;
346
c6044dd1
JB
347/* Maintenance-related settings for this module. */
348
349static struct cmd_list_element *maint_set_ada_cmdlist;
350static struct cmd_list_element *maint_show_ada_cmdlist;
351
352/* Implement the "maintenance set ada" (prefix) command. */
353
354static void
355maint_set_ada_cmd (char *args, int from_tty)
356{
635c7e8a
TT
357 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
358 gdb_stdout);
c6044dd1
JB
359}
360
361/* Implement the "maintenance show ada" (prefix) command. */
362
363static void
364maint_show_ada_cmd (char *args, int from_tty)
365{
366 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
367}
368
369/* The "maintenance ada set/show ignore-descriptive-type" value. */
370
371static int ada_ignore_descriptive_types_p = 0;
372
e802dbe0
JB
373 /* Inferior-specific data. */
374
375/* Per-inferior data for this module. */
376
377struct ada_inferior_data
378{
379 /* The ada__tags__type_specific_data type, which is used when decoding
380 tagged types. With older versions of GNAT, this type was directly
381 accessible through a component ("tsd") in the object tag. But this
382 is no longer the case, so we cache it for each inferior. */
383 struct type *tsd_type;
3eecfa55
JB
384
385 /* The exception_support_info data. This data is used to determine
386 how to implement support for Ada exception catchpoints in a given
387 inferior. */
388 const struct exception_support_info *exception_info;
e802dbe0
JB
389};
390
391/* Our key to this module's inferior data. */
392static const struct inferior_data *ada_inferior_data;
393
394/* A cleanup routine for our inferior data. */
395static void
396ada_inferior_data_cleanup (struct inferior *inf, void *arg)
397{
398 struct ada_inferior_data *data;
399
9a3c8263 400 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
401 if (data != NULL)
402 xfree (data);
403}
404
405/* Return our inferior data for the given inferior (INF).
406
407 This function always returns a valid pointer to an allocated
408 ada_inferior_data structure. If INF's inferior data has not
409 been previously set, this functions creates a new one with all
410 fields set to zero, sets INF's inferior to it, and then returns
411 a pointer to that newly allocated ada_inferior_data. */
412
413static struct ada_inferior_data *
414get_ada_inferior_data (struct inferior *inf)
415{
416 struct ada_inferior_data *data;
417
9a3c8263 418 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
e802dbe0
JB
419 if (data == NULL)
420 {
41bf6aca 421 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
422 set_inferior_data (inf, ada_inferior_data, data);
423 }
424
425 return data;
426}
427
428/* Perform all necessary cleanups regarding our module's inferior data
429 that is required after the inferior INF just exited. */
430
431static void
432ada_inferior_exit (struct inferior *inf)
433{
434 ada_inferior_data_cleanup (inf, NULL);
435 set_inferior_data (inf, ada_inferior_data, NULL);
436}
437
ee01b665
JB
438
439 /* program-space-specific data. */
440
441/* This module's per-program-space data. */
442struct ada_pspace_data
443{
444 /* The Ada symbol cache. */
445 struct ada_symbol_cache *sym_cache;
446};
447
448/* Key to our per-program-space data. */
449static const struct program_space_data *ada_pspace_data_handle;
450
451/* Return this module's data for the given program space (PSPACE).
452 If not is found, add a zero'ed one now.
453
454 This function always returns a valid object. */
455
456static struct ada_pspace_data *
457get_ada_pspace_data (struct program_space *pspace)
458{
459 struct ada_pspace_data *data;
460
9a3c8263
SM
461 data = ((struct ada_pspace_data *)
462 program_space_data (pspace, ada_pspace_data_handle));
ee01b665
JB
463 if (data == NULL)
464 {
465 data = XCNEW (struct ada_pspace_data);
466 set_program_space_data (pspace, ada_pspace_data_handle, data);
467 }
468
469 return data;
470}
471
472/* The cleanup callback for this module's per-program-space data. */
473
474static void
475ada_pspace_data_cleanup (struct program_space *pspace, void *data)
476{
9a3c8263 477 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
ee01b665
JB
478
479 if (pspace_data->sym_cache != NULL)
480 ada_free_symbol_cache (pspace_data->sym_cache);
481 xfree (pspace_data);
482}
483
4c4b4cd2
PH
484 /* Utilities */
485
720d1a40 486/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 487 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
488
489 Normally, we really expect a typedef type to only have 1 typedef layer.
490 In other words, we really expect the target type of a typedef type to be
491 a non-typedef type. This is particularly true for Ada units, because
492 the language does not have a typedef vs not-typedef distinction.
493 In that respect, the Ada compiler has been trying to eliminate as many
494 typedef definitions in the debugging information, since they generally
495 do not bring any extra information (we still use typedef under certain
496 circumstances related mostly to the GNAT encoding).
497
498 Unfortunately, we have seen situations where the debugging information
499 generated by the compiler leads to such multiple typedef layers. For
500 instance, consider the following example with stabs:
501
502 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
503 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
504
505 This is an error in the debugging information which causes type
506 pck__float_array___XUP to be defined twice, and the second time,
507 it is defined as a typedef of a typedef.
508
509 This is on the fringe of legality as far as debugging information is
510 concerned, and certainly unexpected. But it is easy to handle these
511 situations correctly, so we can afford to be lenient in this case. */
512
513static struct type *
514ada_typedef_target_type (struct type *type)
515{
516 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
517 type = TYPE_TARGET_TYPE (type);
518 return type;
519}
520
41d27058
JB
521/* Given DECODED_NAME a string holding a symbol name in its
522 decoded form (ie using the Ada dotted notation), returns
523 its unqualified name. */
524
525static const char *
526ada_unqualified_name (const char *decoded_name)
527{
2b0f535a
JB
528 const char *result;
529
530 /* If the decoded name starts with '<', it means that the encoded
531 name does not follow standard naming conventions, and thus that
532 it is not your typical Ada symbol name. Trying to unqualify it
533 is therefore pointless and possibly erroneous. */
534 if (decoded_name[0] == '<')
535 return decoded_name;
536
537 result = strrchr (decoded_name, '.');
41d27058
JB
538 if (result != NULL)
539 result++; /* Skip the dot... */
540 else
541 result = decoded_name;
542
543 return result;
544}
545
546/* Return a string starting with '<', followed by STR, and '>'.
547 The result is good until the next call. */
548
549static char *
550add_angle_brackets (const char *str)
551{
552 static char *result = NULL;
553
554 xfree (result);
88c15c34 555 result = xstrprintf ("<%s>", str);
41d27058
JB
556 return result;
557}
96d887e8 558
67cb5b2d 559static const char *
4c4b4cd2
PH
560ada_get_gdb_completer_word_break_characters (void)
561{
562 return ada_completer_word_break_characters;
563}
564
e79af960
JB
565/* Print an array element index using the Ada syntax. */
566
567static void
568ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 569 const struct value_print_options *options)
e79af960 570{
79a45b7d 571 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
572 fprintf_filtered (stream, " => ");
573}
574
f27cf670 575/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 576 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 577 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 578
f27cf670
AS
579void *
580grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 581{
d2e4a39e
AS
582 if (*size < min_size)
583 {
584 *size *= 2;
585 if (*size < min_size)
4c4b4cd2 586 *size = min_size;
f27cf670 587 vect = xrealloc (vect, *size * element_size);
d2e4a39e 588 }
f27cf670 589 return vect;
14f9c5c9
AS
590}
591
592/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 593 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
594
595static int
ebf56fd3 596field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
597{
598 int len = strlen (target);
5b4ee69b 599
d2e4a39e 600 return
4c4b4cd2
PH
601 (strncmp (field_name, target, len) == 0
602 && (field_name[len] == '\0'
61012eef 603 || (startswith (field_name + len, "___")
76a01679
JB
604 && strcmp (field_name + strlen (field_name) - 6,
605 "___XVN") != 0)));
14f9c5c9
AS
606}
607
608
872c8b51
JB
609/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
610 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
611 and return its index. This function also handles fields whose name
612 have ___ suffixes because the compiler sometimes alters their name
613 by adding such a suffix to represent fields with certain constraints.
614 If the field could not be found, return a negative number if
615 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
616
617int
618ada_get_field_index (const struct type *type, const char *field_name,
619 int maybe_missing)
620{
621 int fieldno;
872c8b51
JB
622 struct type *struct_type = check_typedef ((struct type *) type);
623
624 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
625 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
626 return fieldno;
627
628 if (!maybe_missing)
323e0a4a 629 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 630 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
631
632 return -1;
633}
634
635/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
636
637int
d2e4a39e 638ada_name_prefix_len (const char *name)
14f9c5c9
AS
639{
640 if (name == NULL)
641 return 0;
d2e4a39e 642 else
14f9c5c9 643 {
d2e4a39e 644 const char *p = strstr (name, "___");
5b4ee69b 645
14f9c5c9 646 if (p == NULL)
4c4b4cd2 647 return strlen (name);
14f9c5c9 648 else
4c4b4cd2 649 return p - name;
14f9c5c9
AS
650 }
651}
652
4c4b4cd2
PH
653/* Return non-zero if SUFFIX is a suffix of STR.
654 Return zero if STR is null. */
655
14f9c5c9 656static int
d2e4a39e 657is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
658{
659 int len1, len2;
5b4ee69b 660
14f9c5c9
AS
661 if (str == NULL)
662 return 0;
663 len1 = strlen (str);
664 len2 = strlen (suffix);
4c4b4cd2 665 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
666}
667
4c4b4cd2
PH
668/* The contents of value VAL, treated as a value of type TYPE. The
669 result is an lval in memory if VAL is. */
14f9c5c9 670
d2e4a39e 671static struct value *
4c4b4cd2 672coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 673{
61ee279c 674 type = ada_check_typedef (type);
df407dfe 675 if (value_type (val) == type)
4c4b4cd2 676 return val;
d2e4a39e 677 else
14f9c5c9 678 {
4c4b4cd2
PH
679 struct value *result;
680
681 /* Make sure that the object size is not unreasonable before
682 trying to allocate some memory for it. */
c1b5a1a6 683 ada_ensure_varsize_limit (type);
4c4b4cd2 684
41e8491f
JK
685 if (value_lazy (val)
686 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
687 result = allocate_value_lazy (type);
688 else
689 {
690 result = allocate_value (type);
9a0dc9e3 691 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 692 }
74bcbdf3 693 set_value_component_location (result, val);
9bbda503
AC
694 set_value_bitsize (result, value_bitsize (val));
695 set_value_bitpos (result, value_bitpos (val));
42ae5230 696 set_value_address (result, value_address (val));
14f9c5c9
AS
697 return result;
698 }
699}
700
fc1a4b47
AC
701static const gdb_byte *
702cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
703{
704 if (valaddr == NULL)
705 return NULL;
706 else
707 return valaddr + offset;
708}
709
710static CORE_ADDR
ebf56fd3 711cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
712{
713 if (address == 0)
714 return 0;
d2e4a39e 715 else
14f9c5c9
AS
716 return address + offset;
717}
718
4c4b4cd2
PH
719/* Issue a warning (as for the definition of warning in utils.c, but
720 with exactly one argument rather than ...), unless the limit on the
721 number of warnings has passed during the evaluation of the current
722 expression. */
a2249542 723
77109804
AC
724/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
725 provided by "complaint". */
a0b31db1 726static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 727
14f9c5c9 728static void
a2249542 729lim_warning (const char *format, ...)
14f9c5c9 730{
a2249542 731 va_list args;
a2249542 732
5b4ee69b 733 va_start (args, format);
4c4b4cd2
PH
734 warnings_issued += 1;
735 if (warnings_issued <= warning_limit)
a2249542
MK
736 vwarning (format, args);
737
738 va_end (args);
4c4b4cd2
PH
739}
740
714e53ab
PH
741/* Issue an error if the size of an object of type T is unreasonable,
742 i.e. if it would be a bad idea to allocate a value of this type in
743 GDB. */
744
c1b5a1a6
JB
745void
746ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
747{
748 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 749 error (_("object size is larger than varsize-limit"));
714e53ab
PH
750}
751
0963b4bd 752/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 753static LONGEST
c3e5cd34 754max_of_size (int size)
4c4b4cd2 755{
76a01679 756 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 757
76a01679 758 return top_bit | (top_bit - 1);
4c4b4cd2
PH
759}
760
0963b4bd 761/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 762static LONGEST
c3e5cd34 763min_of_size (int size)
4c4b4cd2 764{
c3e5cd34 765 return -max_of_size (size) - 1;
4c4b4cd2
PH
766}
767
0963b4bd 768/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 769static ULONGEST
c3e5cd34 770umax_of_size (int size)
4c4b4cd2 771{
76a01679 772 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 773
76a01679 774 return top_bit | (top_bit - 1);
4c4b4cd2
PH
775}
776
0963b4bd 777/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
778static LONGEST
779max_of_type (struct type *t)
4c4b4cd2 780{
c3e5cd34
PH
781 if (TYPE_UNSIGNED (t))
782 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
783 else
784 return max_of_size (TYPE_LENGTH (t));
785}
786
0963b4bd 787/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
788static LONGEST
789min_of_type (struct type *t)
790{
791 if (TYPE_UNSIGNED (t))
792 return 0;
793 else
794 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
795}
796
797/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
798LONGEST
799ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 800{
c3345124 801 type = resolve_dynamic_type (type, NULL, 0);
76a01679 802 switch (TYPE_CODE (type))
4c4b4cd2
PH
803 {
804 case TYPE_CODE_RANGE:
690cc4eb 805 return TYPE_HIGH_BOUND (type);
4c4b4cd2 806 case TYPE_CODE_ENUM:
14e75d8e 807 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
808 case TYPE_CODE_BOOL:
809 return 1;
810 case TYPE_CODE_CHAR:
76a01679 811 case TYPE_CODE_INT:
690cc4eb 812 return max_of_type (type);
4c4b4cd2 813 default:
43bbcdc2 814 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
815 }
816}
817
14e75d8e 818/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
819LONGEST
820ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 821{
c3345124 822 type = resolve_dynamic_type (type, NULL, 0);
76a01679 823 switch (TYPE_CODE (type))
4c4b4cd2
PH
824 {
825 case TYPE_CODE_RANGE:
690cc4eb 826 return TYPE_LOW_BOUND (type);
4c4b4cd2 827 case TYPE_CODE_ENUM:
14e75d8e 828 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
829 case TYPE_CODE_BOOL:
830 return 0;
831 case TYPE_CODE_CHAR:
76a01679 832 case TYPE_CODE_INT:
690cc4eb 833 return min_of_type (type);
4c4b4cd2 834 default:
43bbcdc2 835 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
836 }
837}
838
839/* The identity on non-range types. For range types, the underlying
76a01679 840 non-range scalar type. */
4c4b4cd2
PH
841
842static struct type *
18af8284 843get_base_type (struct type *type)
4c4b4cd2
PH
844{
845 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
846 {
76a01679
JB
847 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
848 return type;
4c4b4cd2
PH
849 type = TYPE_TARGET_TYPE (type);
850 }
851 return type;
14f9c5c9 852}
41246937
JB
853
854/* Return a decoded version of the given VALUE. This means returning
855 a value whose type is obtained by applying all the GNAT-specific
856 encondings, making the resulting type a static but standard description
857 of the initial type. */
858
859struct value *
860ada_get_decoded_value (struct value *value)
861{
862 struct type *type = ada_check_typedef (value_type (value));
863
864 if (ada_is_array_descriptor_type (type)
865 || (ada_is_constrained_packed_array_type (type)
866 && TYPE_CODE (type) != TYPE_CODE_PTR))
867 {
868 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
869 value = ada_coerce_to_simple_array_ptr (value);
870 else
871 value = ada_coerce_to_simple_array (value);
872 }
873 else
874 value = ada_to_fixed_value (value);
875
876 return value;
877}
878
879/* Same as ada_get_decoded_value, but with the given TYPE.
880 Because there is no associated actual value for this type,
881 the resulting type might be a best-effort approximation in
882 the case of dynamic types. */
883
884struct type *
885ada_get_decoded_type (struct type *type)
886{
887 type = to_static_fixed_type (type);
888 if (ada_is_constrained_packed_array_type (type))
889 type = ada_coerce_to_simple_array_type (type);
890 return type;
891}
892
4c4b4cd2 893\f
76a01679 894
4c4b4cd2 895 /* Language Selection */
14f9c5c9
AS
896
897/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 898 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 899
14f9c5c9 900enum language
ccefe4c4 901ada_update_initial_language (enum language lang)
14f9c5c9 902{
d2e4a39e 903 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 904 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 905 return language_ada;
14f9c5c9
AS
906
907 return lang;
908}
96d887e8
PH
909
910/* If the main procedure is written in Ada, then return its name.
911 The result is good until the next call. Return NULL if the main
912 procedure doesn't appear to be in Ada. */
913
914char *
915ada_main_name (void)
916{
3b7344d5 917 struct bound_minimal_symbol msym;
f9bc20b9 918 static char *main_program_name = NULL;
6c038f32 919
96d887e8
PH
920 /* For Ada, the name of the main procedure is stored in a specific
921 string constant, generated by the binder. Look for that symbol,
922 extract its address, and then read that string. If we didn't find
923 that string, then most probably the main procedure is not written
924 in Ada. */
925 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
926
3b7344d5 927 if (msym.minsym != NULL)
96d887e8 928 {
f9bc20b9
JB
929 CORE_ADDR main_program_name_addr;
930 int err_code;
931
77e371c0 932 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 933 if (main_program_name_addr == 0)
323e0a4a 934 error (_("Invalid address for Ada main program name."));
96d887e8 935
f9bc20b9
JB
936 xfree (main_program_name);
937 target_read_string (main_program_name_addr, &main_program_name,
938 1024, &err_code);
939
940 if (err_code != 0)
941 return NULL;
96d887e8
PH
942 return main_program_name;
943 }
944
945 /* The main procedure doesn't seem to be in Ada. */
946 return NULL;
947}
14f9c5c9 948\f
4c4b4cd2 949 /* Symbols */
d2e4a39e 950
4c4b4cd2
PH
951/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
952 of NULLs. */
14f9c5c9 953
d2e4a39e
AS
954const struct ada_opname_map ada_opname_table[] = {
955 {"Oadd", "\"+\"", BINOP_ADD},
956 {"Osubtract", "\"-\"", BINOP_SUB},
957 {"Omultiply", "\"*\"", BINOP_MUL},
958 {"Odivide", "\"/\"", BINOP_DIV},
959 {"Omod", "\"mod\"", BINOP_MOD},
960 {"Orem", "\"rem\"", BINOP_REM},
961 {"Oexpon", "\"**\"", BINOP_EXP},
962 {"Olt", "\"<\"", BINOP_LESS},
963 {"Ole", "\"<=\"", BINOP_LEQ},
964 {"Ogt", "\">\"", BINOP_GTR},
965 {"Oge", "\">=\"", BINOP_GEQ},
966 {"Oeq", "\"=\"", BINOP_EQUAL},
967 {"One", "\"/=\"", BINOP_NOTEQUAL},
968 {"Oand", "\"and\"", BINOP_BITWISE_AND},
969 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
970 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
971 {"Oconcat", "\"&\"", BINOP_CONCAT},
972 {"Oabs", "\"abs\"", UNOP_ABS},
973 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
974 {"Oadd", "\"+\"", UNOP_PLUS},
975 {"Osubtract", "\"-\"", UNOP_NEG},
976 {NULL, NULL}
14f9c5c9
AS
977};
978
4c4b4cd2
PH
979/* The "encoded" form of DECODED, according to GNAT conventions.
980 The result is valid until the next call to ada_encode. */
981
14f9c5c9 982char *
4c4b4cd2 983ada_encode (const char *decoded)
14f9c5c9 984{
4c4b4cd2
PH
985 static char *encoding_buffer = NULL;
986 static size_t encoding_buffer_size = 0;
d2e4a39e 987 const char *p;
14f9c5c9 988 int k;
d2e4a39e 989
4c4b4cd2 990 if (decoded == NULL)
14f9c5c9
AS
991 return NULL;
992
4c4b4cd2
PH
993 GROW_VECT (encoding_buffer, encoding_buffer_size,
994 2 * strlen (decoded) + 10);
14f9c5c9
AS
995
996 k = 0;
4c4b4cd2 997 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 998 {
cdc7bb92 999 if (*p == '.')
4c4b4cd2
PH
1000 {
1001 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1002 k += 2;
1003 }
14f9c5c9 1004 else if (*p == '"')
4c4b4cd2
PH
1005 {
1006 const struct ada_opname_map *mapping;
1007
1008 for (mapping = ada_opname_table;
1265e4aa 1009 mapping->encoded != NULL
61012eef 1010 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1011 ;
1012 if (mapping->encoded == NULL)
323e0a4a 1013 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
1014 strcpy (encoding_buffer + k, mapping->encoded);
1015 k += strlen (mapping->encoded);
1016 break;
1017 }
d2e4a39e 1018 else
4c4b4cd2
PH
1019 {
1020 encoding_buffer[k] = *p;
1021 k += 1;
1022 }
14f9c5c9
AS
1023 }
1024
4c4b4cd2
PH
1025 encoding_buffer[k] = '\0';
1026 return encoding_buffer;
14f9c5c9
AS
1027}
1028
1029/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1030 quotes, unfolded, but with the quotes stripped away. Result good
1031 to next call. */
1032
d2e4a39e
AS
1033char *
1034ada_fold_name (const char *name)
14f9c5c9 1035{
d2e4a39e 1036 static char *fold_buffer = NULL;
14f9c5c9
AS
1037 static size_t fold_buffer_size = 0;
1038
1039 int len = strlen (name);
d2e4a39e 1040 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1041
1042 if (name[0] == '\'')
1043 {
d2e4a39e
AS
1044 strncpy (fold_buffer, name + 1, len - 2);
1045 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1046 }
1047 else
1048 {
1049 int i;
5b4ee69b 1050
14f9c5c9 1051 for (i = 0; i <= len; i += 1)
4c4b4cd2 1052 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1053 }
1054
1055 return fold_buffer;
1056}
1057
529cad9c
PH
1058/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1059
1060static int
1061is_lower_alphanum (const char c)
1062{
1063 return (isdigit (c) || (isalpha (c) && islower (c)));
1064}
1065
c90092fe
JB
1066/* ENCODED is the linkage name of a symbol and LEN contains its length.
1067 This function saves in LEN the length of that same symbol name but
1068 without either of these suffixes:
29480c32
JB
1069 . .{DIGIT}+
1070 . ${DIGIT}+
1071 . ___{DIGIT}+
1072 . __{DIGIT}+.
c90092fe 1073
29480c32
JB
1074 These are suffixes introduced by the compiler for entities such as
1075 nested subprogram for instance, in order to avoid name clashes.
1076 They do not serve any purpose for the debugger. */
1077
1078static void
1079ada_remove_trailing_digits (const char *encoded, int *len)
1080{
1081 if (*len > 1 && isdigit (encoded[*len - 1]))
1082 {
1083 int i = *len - 2;
5b4ee69b 1084
29480c32
JB
1085 while (i > 0 && isdigit (encoded[i]))
1086 i--;
1087 if (i >= 0 && encoded[i] == '.')
1088 *len = i;
1089 else if (i >= 0 && encoded[i] == '$')
1090 *len = i;
61012eef 1091 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1092 *len = i - 2;
61012eef 1093 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1094 *len = i - 1;
1095 }
1096}
1097
1098/* Remove the suffix introduced by the compiler for protected object
1099 subprograms. */
1100
1101static void
1102ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1103{
1104 /* Remove trailing N. */
1105
1106 /* Protected entry subprograms are broken into two
1107 separate subprograms: The first one is unprotected, and has
1108 a 'N' suffix; the second is the protected version, and has
0963b4bd 1109 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1110 the protection. Since the P subprograms are internally generated,
1111 we leave these names undecoded, giving the user a clue that this
1112 entity is internal. */
1113
1114 if (*len > 1
1115 && encoded[*len - 1] == 'N'
1116 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1117 *len = *len - 1;
1118}
1119
69fadcdf
JB
1120/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1121
1122static void
1123ada_remove_Xbn_suffix (const char *encoded, int *len)
1124{
1125 int i = *len - 1;
1126
1127 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1128 i--;
1129
1130 if (encoded[i] != 'X')
1131 return;
1132
1133 if (i == 0)
1134 return;
1135
1136 if (isalnum (encoded[i-1]))
1137 *len = i;
1138}
1139
29480c32
JB
1140/* If ENCODED follows the GNAT entity encoding conventions, then return
1141 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1142 replaced by ENCODED.
14f9c5c9 1143
4c4b4cd2 1144 The resulting string is valid until the next call of ada_decode.
29480c32 1145 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1146 is returned. */
1147
1148const char *
1149ada_decode (const char *encoded)
14f9c5c9
AS
1150{
1151 int i, j;
1152 int len0;
d2e4a39e 1153 const char *p;
4c4b4cd2 1154 char *decoded;
14f9c5c9 1155 int at_start_name;
4c4b4cd2
PH
1156 static char *decoding_buffer = NULL;
1157 static size_t decoding_buffer_size = 0;
d2e4a39e 1158
29480c32
JB
1159 /* The name of the Ada main procedure starts with "_ada_".
1160 This prefix is not part of the decoded name, so skip this part
1161 if we see this prefix. */
61012eef 1162 if (startswith (encoded, "_ada_"))
4c4b4cd2 1163 encoded += 5;
14f9c5c9 1164
29480c32
JB
1165 /* If the name starts with '_', then it is not a properly encoded
1166 name, so do not attempt to decode it. Similarly, if the name
1167 starts with '<', the name should not be decoded. */
4c4b4cd2 1168 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1169 goto Suppress;
1170
4c4b4cd2 1171 len0 = strlen (encoded);
4c4b4cd2 1172
29480c32
JB
1173 ada_remove_trailing_digits (encoded, &len0);
1174 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1175
4c4b4cd2
PH
1176 /* Remove the ___X.* suffix if present. Do not forget to verify that
1177 the suffix is located before the current "end" of ENCODED. We want
1178 to avoid re-matching parts of ENCODED that have previously been
1179 marked as discarded (by decrementing LEN0). */
1180 p = strstr (encoded, "___");
1181 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1182 {
1183 if (p[3] == 'X')
4c4b4cd2 1184 len0 = p - encoded;
14f9c5c9 1185 else
4c4b4cd2 1186 goto Suppress;
14f9c5c9 1187 }
4c4b4cd2 1188
29480c32
JB
1189 /* Remove any trailing TKB suffix. It tells us that this symbol
1190 is for the body of a task, but that information does not actually
1191 appear in the decoded name. */
1192
61012eef 1193 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1194 len0 -= 3;
76a01679 1195
a10967fa
JB
1196 /* Remove any trailing TB suffix. The TB suffix is slightly different
1197 from the TKB suffix because it is used for non-anonymous task
1198 bodies. */
1199
61012eef 1200 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1201 len0 -= 2;
1202
29480c32
JB
1203 /* Remove trailing "B" suffixes. */
1204 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1205
61012eef 1206 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1207 len0 -= 1;
1208
4c4b4cd2 1209 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1210
4c4b4cd2
PH
1211 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1212 decoded = decoding_buffer;
14f9c5c9 1213
29480c32
JB
1214 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1215
4c4b4cd2 1216 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1217 {
4c4b4cd2
PH
1218 i = len0 - 2;
1219 while ((i >= 0 && isdigit (encoded[i]))
1220 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1221 i -= 1;
1222 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1223 len0 = i - 1;
1224 else if (encoded[i] == '$')
1225 len0 = i;
d2e4a39e 1226 }
14f9c5c9 1227
29480c32
JB
1228 /* The first few characters that are not alphabetic are not part
1229 of any encoding we use, so we can copy them over verbatim. */
1230
4c4b4cd2
PH
1231 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1232 decoded[j] = encoded[i];
14f9c5c9
AS
1233
1234 at_start_name = 1;
1235 while (i < len0)
1236 {
29480c32 1237 /* Is this a symbol function? */
4c4b4cd2
PH
1238 if (at_start_name && encoded[i] == 'O')
1239 {
1240 int k;
5b4ee69b 1241
4c4b4cd2
PH
1242 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1243 {
1244 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1245 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1246 op_len - 1) == 0)
1247 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1248 {
1249 strcpy (decoded + j, ada_opname_table[k].decoded);
1250 at_start_name = 0;
1251 i += op_len;
1252 j += strlen (ada_opname_table[k].decoded);
1253 break;
1254 }
1255 }
1256 if (ada_opname_table[k].encoded != NULL)
1257 continue;
1258 }
14f9c5c9
AS
1259 at_start_name = 0;
1260
529cad9c
PH
1261 /* Replace "TK__" with "__", which will eventually be translated
1262 into "." (just below). */
1263
61012eef 1264 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1265 i += 2;
529cad9c 1266
29480c32
JB
1267 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1268 be translated into "." (just below). These are internal names
1269 generated for anonymous blocks inside which our symbol is nested. */
1270
1271 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1272 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1273 && isdigit (encoded [i+4]))
1274 {
1275 int k = i + 5;
1276
1277 while (k < len0 && isdigit (encoded[k]))
1278 k++; /* Skip any extra digit. */
1279
1280 /* Double-check that the "__B_{DIGITS}+" sequence we found
1281 is indeed followed by "__". */
1282 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1283 i = k;
1284 }
1285
529cad9c
PH
1286 /* Remove _E{DIGITS}+[sb] */
1287
1288 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1289 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1290 one implements the actual entry code, and has a suffix following
1291 the convention above; the second one implements the barrier and
1292 uses the same convention as above, except that the 'E' is replaced
1293 by a 'B'.
1294
1295 Just as above, we do not decode the name of barrier functions
1296 to give the user a clue that the code he is debugging has been
1297 internally generated. */
1298
1299 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1300 && isdigit (encoded[i+2]))
1301 {
1302 int k = i + 3;
1303
1304 while (k < len0 && isdigit (encoded[k]))
1305 k++;
1306
1307 if (k < len0
1308 && (encoded[k] == 'b' || encoded[k] == 's'))
1309 {
1310 k++;
1311 /* Just as an extra precaution, make sure that if this
1312 suffix is followed by anything else, it is a '_'.
1313 Otherwise, we matched this sequence by accident. */
1314 if (k == len0
1315 || (k < len0 && encoded[k] == '_'))
1316 i = k;
1317 }
1318 }
1319
1320 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1321 the GNAT front-end in protected object subprograms. */
1322
1323 if (i < len0 + 3
1324 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1325 {
1326 /* Backtrack a bit up until we reach either the begining of
1327 the encoded name, or "__". Make sure that we only find
1328 digits or lowercase characters. */
1329 const char *ptr = encoded + i - 1;
1330
1331 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1332 ptr--;
1333 if (ptr < encoded
1334 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1335 i++;
1336 }
1337
4c4b4cd2
PH
1338 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1339 {
29480c32
JB
1340 /* This is a X[bn]* sequence not separated from the previous
1341 part of the name with a non-alpha-numeric character (in other
1342 words, immediately following an alpha-numeric character), then
1343 verify that it is placed at the end of the encoded name. If
1344 not, then the encoding is not valid and we should abort the
1345 decoding. Otherwise, just skip it, it is used in body-nested
1346 package names. */
4c4b4cd2
PH
1347 do
1348 i += 1;
1349 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1350 if (i < len0)
1351 goto Suppress;
1352 }
cdc7bb92 1353 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1354 {
29480c32 1355 /* Replace '__' by '.'. */
4c4b4cd2
PH
1356 decoded[j] = '.';
1357 at_start_name = 1;
1358 i += 2;
1359 j += 1;
1360 }
14f9c5c9 1361 else
4c4b4cd2 1362 {
29480c32
JB
1363 /* It's a character part of the decoded name, so just copy it
1364 over. */
4c4b4cd2
PH
1365 decoded[j] = encoded[i];
1366 i += 1;
1367 j += 1;
1368 }
14f9c5c9 1369 }
4c4b4cd2 1370 decoded[j] = '\000';
14f9c5c9 1371
29480c32
JB
1372 /* Decoded names should never contain any uppercase character.
1373 Double-check this, and abort the decoding if we find one. */
1374
4c4b4cd2
PH
1375 for (i = 0; decoded[i] != '\0'; i += 1)
1376 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1377 goto Suppress;
1378
4c4b4cd2
PH
1379 if (strcmp (decoded, encoded) == 0)
1380 return encoded;
1381 else
1382 return decoded;
14f9c5c9
AS
1383
1384Suppress:
4c4b4cd2
PH
1385 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1386 decoded = decoding_buffer;
1387 if (encoded[0] == '<')
1388 strcpy (decoded, encoded);
14f9c5c9 1389 else
88c15c34 1390 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1391 return decoded;
1392
1393}
1394
1395/* Table for keeping permanent unique copies of decoded names. Once
1396 allocated, names in this table are never released. While this is a
1397 storage leak, it should not be significant unless there are massive
1398 changes in the set of decoded names in successive versions of a
1399 symbol table loaded during a single session. */
1400static struct htab *decoded_names_store;
1401
1402/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1403 in the language-specific part of GSYMBOL, if it has not been
1404 previously computed. Tries to save the decoded name in the same
1405 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1406 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1407 GSYMBOL).
4c4b4cd2
PH
1408 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1409 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1410 when a decoded name is cached in it. */
4c4b4cd2 1411
45e6c716 1412const char *
f85f34ed 1413ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1414{
f85f34ed
TT
1415 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1416 const char **resultp =
615b3f62 1417 &gsymbol->language_specific.demangled_name;
5b4ee69b 1418
f85f34ed 1419 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1420 {
1421 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1422 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1423
f85f34ed 1424 gsymbol->ada_mangled = 1;
5b4ee69b 1425
f85f34ed 1426 if (obstack != NULL)
224c3ddb
SM
1427 *resultp
1428 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
f85f34ed 1429 else
76a01679 1430 {
f85f34ed
TT
1431 /* Sometimes, we can't find a corresponding objfile, in
1432 which case, we put the result on the heap. Since we only
1433 decode when needed, we hope this usually does not cause a
1434 significant memory leak (FIXME). */
1435
76a01679
JB
1436 char **slot = (char **) htab_find_slot (decoded_names_store,
1437 decoded, INSERT);
5b4ee69b 1438
76a01679
JB
1439 if (*slot == NULL)
1440 *slot = xstrdup (decoded);
1441 *resultp = *slot;
1442 }
4c4b4cd2 1443 }
14f9c5c9 1444
4c4b4cd2
PH
1445 return *resultp;
1446}
76a01679 1447
2c0b251b 1448static char *
76a01679 1449ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1450{
1451 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1452}
1453
8b302db8
TT
1454/* Implement la_sniff_from_mangled_name for Ada. */
1455
1456static int
1457ada_sniff_from_mangled_name (const char *mangled, char **out)
1458{
1459 const char *demangled = ada_decode (mangled);
1460
1461 *out = NULL;
1462
1463 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1464 {
1465 /* Set the gsymbol language to Ada, but still return 0.
1466 Two reasons for that:
1467
1468 1. For Ada, we prefer computing the symbol's decoded name
1469 on the fly rather than pre-compute it, in order to save
1470 memory (Ada projects are typically very large).
1471
1472 2. There are some areas in the definition of the GNAT
1473 encoding where, with a bit of bad luck, we might be able
1474 to decode a non-Ada symbol, generating an incorrect
1475 demangled name (Eg: names ending with "TB" for instance
1476 are identified as task bodies and so stripped from
1477 the decoded name returned).
1478
1479 Returning 1, here, but not setting *DEMANGLED, helps us get a
1480 little bit of the best of both worlds. Because we're last,
1481 we should not affect any of the other languages that were
1482 able to demangle the symbol before us; we get to correctly
1483 tag Ada symbols as such; and even if we incorrectly tagged a
1484 non-Ada symbol, which should be rare, any routing through the
1485 Ada language should be transparent (Ada tries to behave much
1486 like C/C++ with non-Ada symbols). */
1487 return 1;
1488 }
1489
1490 return 0;
1491}
1492
14f9c5c9 1493/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1494 suffixes that encode debugging information or leading _ada_ on
1495 SYM_NAME (see is_name_suffix commentary for the debugging
1496 information that is ignored). If WILD, then NAME need only match a
1497 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1498 either argument is NULL. */
14f9c5c9 1499
2c0b251b 1500static int
40658b94 1501match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1502{
1503 if (sym_name == NULL || name == NULL)
1504 return 0;
1505 else if (wild)
73589123 1506 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1507 else
1508 {
1509 int len_name = strlen (name);
5b4ee69b 1510
4c4b4cd2
PH
1511 return (strncmp (sym_name, name, len_name) == 0
1512 && is_name_suffix (sym_name + len_name))
61012eef 1513 || (startswith (sym_name, "_ada_")
4c4b4cd2
PH
1514 && strncmp (sym_name + 5, name, len_name) == 0
1515 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1516 }
14f9c5c9 1517}
14f9c5c9 1518\f
d2e4a39e 1519
4c4b4cd2 1520 /* Arrays */
14f9c5c9 1521
28c85d6c
JB
1522/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1523 generated by the GNAT compiler to describe the index type used
1524 for each dimension of an array, check whether it follows the latest
1525 known encoding. If not, fix it up to conform to the latest encoding.
1526 Otherwise, do nothing. This function also does nothing if
1527 INDEX_DESC_TYPE is NULL.
1528
1529 The GNAT encoding used to describle the array index type evolved a bit.
1530 Initially, the information would be provided through the name of each
1531 field of the structure type only, while the type of these fields was
1532 described as unspecified and irrelevant. The debugger was then expected
1533 to perform a global type lookup using the name of that field in order
1534 to get access to the full index type description. Because these global
1535 lookups can be very expensive, the encoding was later enhanced to make
1536 the global lookup unnecessary by defining the field type as being
1537 the full index type description.
1538
1539 The purpose of this routine is to allow us to support older versions
1540 of the compiler by detecting the use of the older encoding, and by
1541 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1542 we essentially replace each field's meaningless type by the associated
1543 index subtype). */
1544
1545void
1546ada_fixup_array_indexes_type (struct type *index_desc_type)
1547{
1548 int i;
1549
1550 if (index_desc_type == NULL)
1551 return;
1552 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1553
1554 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1555 to check one field only, no need to check them all). If not, return
1556 now.
1557
1558 If our INDEX_DESC_TYPE was generated using the older encoding,
1559 the field type should be a meaningless integer type whose name
1560 is not equal to the field name. */
1561 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1562 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1563 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1564 return;
1565
1566 /* Fixup each field of INDEX_DESC_TYPE. */
1567 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1568 {
0d5cff50 1569 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1570 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1571
1572 if (raw_type)
1573 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1574 }
1575}
1576
4c4b4cd2 1577/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1578
a121b7c1 1579static const char *bound_name[] = {
d2e4a39e 1580 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1581 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1582};
1583
1584/* Maximum number of array dimensions we are prepared to handle. */
1585
4c4b4cd2 1586#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1587
14f9c5c9 1588
4c4b4cd2
PH
1589/* The desc_* routines return primitive portions of array descriptors
1590 (fat pointers). */
14f9c5c9
AS
1591
1592/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1593 level of indirection, if needed. */
1594
d2e4a39e
AS
1595static struct type *
1596desc_base_type (struct type *type)
14f9c5c9
AS
1597{
1598 if (type == NULL)
1599 return NULL;
61ee279c 1600 type = ada_check_typedef (type);
720d1a40
JB
1601 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1602 type = ada_typedef_target_type (type);
1603
1265e4aa
JB
1604 if (type != NULL
1605 && (TYPE_CODE (type) == TYPE_CODE_PTR
1606 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1607 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1608 else
1609 return type;
1610}
1611
4c4b4cd2
PH
1612/* True iff TYPE indicates a "thin" array pointer type. */
1613
14f9c5c9 1614static int
d2e4a39e 1615is_thin_pntr (struct type *type)
14f9c5c9 1616{
d2e4a39e 1617 return
14f9c5c9
AS
1618 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1619 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1620}
1621
4c4b4cd2
PH
1622/* The descriptor type for thin pointer type TYPE. */
1623
d2e4a39e
AS
1624static struct type *
1625thin_descriptor_type (struct type *type)
14f9c5c9 1626{
d2e4a39e 1627 struct type *base_type = desc_base_type (type);
5b4ee69b 1628
14f9c5c9
AS
1629 if (base_type == NULL)
1630 return NULL;
1631 if (is_suffix (ada_type_name (base_type), "___XVE"))
1632 return base_type;
d2e4a39e 1633 else
14f9c5c9 1634 {
d2e4a39e 1635 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1636
14f9c5c9 1637 if (alt_type == NULL)
4c4b4cd2 1638 return base_type;
14f9c5c9 1639 else
4c4b4cd2 1640 return alt_type;
14f9c5c9
AS
1641 }
1642}
1643
4c4b4cd2
PH
1644/* A pointer to the array data for thin-pointer value VAL. */
1645
d2e4a39e
AS
1646static struct value *
1647thin_data_pntr (struct value *val)
14f9c5c9 1648{
828292f2 1649 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1650 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1651
556bdfd4
UW
1652 data_type = lookup_pointer_type (data_type);
1653
14f9c5c9 1654 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1655 return value_cast (data_type, value_copy (val));
d2e4a39e 1656 else
42ae5230 1657 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1658}
1659
4c4b4cd2
PH
1660/* True iff TYPE indicates a "thick" array pointer type. */
1661
14f9c5c9 1662static int
d2e4a39e 1663is_thick_pntr (struct type *type)
14f9c5c9
AS
1664{
1665 type = desc_base_type (type);
1666 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1667 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1668}
1669
4c4b4cd2
PH
1670/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1671 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1672
d2e4a39e
AS
1673static struct type *
1674desc_bounds_type (struct type *type)
14f9c5c9 1675{
d2e4a39e 1676 struct type *r;
14f9c5c9
AS
1677
1678 type = desc_base_type (type);
1679
1680 if (type == NULL)
1681 return NULL;
1682 else if (is_thin_pntr (type))
1683 {
1684 type = thin_descriptor_type (type);
1685 if (type == NULL)
4c4b4cd2 1686 return NULL;
14f9c5c9
AS
1687 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1688 if (r != NULL)
61ee279c 1689 return ada_check_typedef (r);
14f9c5c9
AS
1690 }
1691 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1692 {
1693 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1694 if (r != NULL)
61ee279c 1695 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1696 }
1697 return NULL;
1698}
1699
1700/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1701 one, a pointer to its bounds data. Otherwise NULL. */
1702
d2e4a39e
AS
1703static struct value *
1704desc_bounds (struct value *arr)
14f9c5c9 1705{
df407dfe 1706 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1707
d2e4a39e 1708 if (is_thin_pntr (type))
14f9c5c9 1709 {
d2e4a39e 1710 struct type *bounds_type =
4c4b4cd2 1711 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1712 LONGEST addr;
1713
4cdfadb1 1714 if (bounds_type == NULL)
323e0a4a 1715 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1716
1717 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1718 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1719 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1720 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1721 addr = value_as_long (arr);
d2e4a39e 1722 else
42ae5230 1723 addr = value_address (arr);
14f9c5c9 1724
d2e4a39e 1725 return
4c4b4cd2
PH
1726 value_from_longest (lookup_pointer_type (bounds_type),
1727 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1728 }
1729
1730 else if (is_thick_pntr (type))
05e522ef
JB
1731 {
1732 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1733 _("Bad GNAT array descriptor"));
1734 struct type *p_bounds_type = value_type (p_bounds);
1735
1736 if (p_bounds_type
1737 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1738 {
1739 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1740
1741 if (TYPE_STUB (target_type))
1742 p_bounds = value_cast (lookup_pointer_type
1743 (ada_check_typedef (target_type)),
1744 p_bounds);
1745 }
1746 else
1747 error (_("Bad GNAT array descriptor"));
1748
1749 return p_bounds;
1750 }
14f9c5c9
AS
1751 else
1752 return NULL;
1753}
1754
4c4b4cd2
PH
1755/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1756 position of the field containing the address of the bounds data. */
1757
14f9c5c9 1758static int
d2e4a39e 1759fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1760{
1761 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1762}
1763
1764/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1765 size of the field containing the address of the bounds data. */
1766
14f9c5c9 1767static int
d2e4a39e 1768fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1769{
1770 type = desc_base_type (type);
1771
d2e4a39e 1772 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1773 return TYPE_FIELD_BITSIZE (type, 1);
1774 else
61ee279c 1775 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1776}
1777
4c4b4cd2 1778/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1779 pointer to one, the type of its array data (a array-with-no-bounds type);
1780 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1781 data. */
4c4b4cd2 1782
d2e4a39e 1783static struct type *
556bdfd4 1784desc_data_target_type (struct type *type)
14f9c5c9
AS
1785{
1786 type = desc_base_type (type);
1787
4c4b4cd2 1788 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1789 if (is_thin_pntr (type))
556bdfd4 1790 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1791 else if (is_thick_pntr (type))
556bdfd4
UW
1792 {
1793 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1794
1795 if (data_type
1796 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1797 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1798 }
1799
1800 return NULL;
14f9c5c9
AS
1801}
1802
1803/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1804 its array data. */
4c4b4cd2 1805
d2e4a39e
AS
1806static struct value *
1807desc_data (struct value *arr)
14f9c5c9 1808{
df407dfe 1809 struct type *type = value_type (arr);
5b4ee69b 1810
14f9c5c9
AS
1811 if (is_thin_pntr (type))
1812 return thin_data_pntr (arr);
1813 else if (is_thick_pntr (type))
d2e4a39e 1814 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1815 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1816 else
1817 return NULL;
1818}
1819
1820
1821/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1822 position of the field containing the address of the data. */
1823
14f9c5c9 1824static int
d2e4a39e 1825fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1826{
1827 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1828}
1829
1830/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1831 size of the field containing the address of the data. */
1832
14f9c5c9 1833static int
d2e4a39e 1834fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1835{
1836 type = desc_base_type (type);
1837
1838 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1839 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1840 else
14f9c5c9
AS
1841 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1842}
1843
4c4b4cd2 1844/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1845 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1846 bound, if WHICH is 1. The first bound is I=1. */
1847
d2e4a39e
AS
1848static struct value *
1849desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1850{
d2e4a39e 1851 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1852 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1853}
1854
1855/* If BOUNDS is an array-bounds structure type, return the bit position
1856 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1857 bound, if WHICH is 1. The first bound is I=1. */
1858
14f9c5c9 1859static int
d2e4a39e 1860desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1861{
d2e4a39e 1862 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1863}
1864
1865/* If BOUNDS is an array-bounds structure type, return the bit field size
1866 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1867 bound, if WHICH is 1. The first bound is I=1. */
1868
76a01679 1869static int
d2e4a39e 1870desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1871{
1872 type = desc_base_type (type);
1873
d2e4a39e
AS
1874 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1875 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1876 else
1877 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1878}
1879
1880/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1881 Ith bound (numbering from 1). Otherwise, NULL. */
1882
d2e4a39e
AS
1883static struct type *
1884desc_index_type (struct type *type, int i)
14f9c5c9
AS
1885{
1886 type = desc_base_type (type);
1887
1888 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1889 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1890 else
14f9c5c9
AS
1891 return NULL;
1892}
1893
4c4b4cd2
PH
1894/* The number of index positions in the array-bounds type TYPE.
1895 Return 0 if TYPE is NULL. */
1896
14f9c5c9 1897static int
d2e4a39e 1898desc_arity (struct type *type)
14f9c5c9
AS
1899{
1900 type = desc_base_type (type);
1901
1902 if (type != NULL)
1903 return TYPE_NFIELDS (type) / 2;
1904 return 0;
1905}
1906
4c4b4cd2
PH
1907/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1908 an array descriptor type (representing an unconstrained array
1909 type). */
1910
76a01679
JB
1911static int
1912ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1913{
1914 if (type == NULL)
1915 return 0;
61ee279c 1916 type = ada_check_typedef (type);
4c4b4cd2 1917 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1918 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1919}
1920
52ce6436 1921/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1922 * to one. */
52ce6436 1923
2c0b251b 1924static int
52ce6436
PH
1925ada_is_array_type (struct type *type)
1926{
1927 while (type != NULL
1928 && (TYPE_CODE (type) == TYPE_CODE_PTR
1929 || TYPE_CODE (type) == TYPE_CODE_REF))
1930 type = TYPE_TARGET_TYPE (type);
1931 return ada_is_direct_array_type (type);
1932}
1933
4c4b4cd2 1934/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1935
14f9c5c9 1936int
4c4b4cd2 1937ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1938{
1939 if (type == NULL)
1940 return 0;
61ee279c 1941 type = ada_check_typedef (type);
14f9c5c9 1942 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1943 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1944 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1945 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1946}
1947
4c4b4cd2
PH
1948/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1949
14f9c5c9 1950int
4c4b4cd2 1951ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1952{
556bdfd4 1953 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1954
1955 if (type == NULL)
1956 return 0;
61ee279c 1957 type = ada_check_typedef (type);
556bdfd4
UW
1958 return (data_type != NULL
1959 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1960 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1961}
1962
1963/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1964 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1965 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1966 is still needed. */
1967
14f9c5c9 1968int
ebf56fd3 1969ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1970{
d2e4a39e 1971 return
14f9c5c9
AS
1972 type != NULL
1973 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1974 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1975 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1976 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1977}
1978
1979
4c4b4cd2 1980/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1981 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1982 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1983 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1984 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1985 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1986 a descriptor. */
d2e4a39e
AS
1987struct type *
1988ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1989{
ad82864c
JB
1990 if (ada_is_constrained_packed_array_type (value_type (arr)))
1991 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1992
df407dfe
AC
1993 if (!ada_is_array_descriptor_type (value_type (arr)))
1994 return value_type (arr);
d2e4a39e
AS
1995
1996 if (!bounds)
ad82864c
JB
1997 {
1998 struct type *array_type =
1999 ada_check_typedef (desc_data_target_type (value_type (arr)));
2000
2001 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2002 TYPE_FIELD_BITSIZE (array_type, 0) =
2003 decode_packed_array_bitsize (value_type (arr));
2004
2005 return array_type;
2006 }
14f9c5c9
AS
2007 else
2008 {
d2e4a39e 2009 struct type *elt_type;
14f9c5c9 2010 int arity;
d2e4a39e 2011 struct value *descriptor;
14f9c5c9 2012
df407dfe
AC
2013 elt_type = ada_array_element_type (value_type (arr), -1);
2014 arity = ada_array_arity (value_type (arr));
14f9c5c9 2015
d2e4a39e 2016 if (elt_type == NULL || arity == 0)
df407dfe 2017 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
2018
2019 descriptor = desc_bounds (arr);
d2e4a39e 2020 if (value_as_long (descriptor) == 0)
4c4b4cd2 2021 return NULL;
d2e4a39e 2022 while (arity > 0)
4c4b4cd2 2023 {
e9bb382b
UW
2024 struct type *range_type = alloc_type_copy (value_type (arr));
2025 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
2026 struct value *low = desc_one_bound (descriptor, arity, 0);
2027 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 2028
5b4ee69b 2029 arity -= 1;
0c9c3474
SA
2030 create_static_range_type (range_type, value_type (low),
2031 longest_to_int (value_as_long (low)),
2032 longest_to_int (value_as_long (high)));
4c4b4cd2 2033 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
2034
2035 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
2036 {
2037 /* We need to store the element packed bitsize, as well as
2038 recompute the array size, because it was previously
2039 computed based on the unpacked element size. */
2040 LONGEST lo = value_as_long (low);
2041 LONGEST hi = value_as_long (high);
2042
2043 TYPE_FIELD_BITSIZE (elt_type, 0) =
2044 decode_packed_array_bitsize (value_type (arr));
2045 /* If the array has no element, then the size is already
2046 zero, and does not need to be recomputed. */
2047 if (lo < hi)
2048 {
2049 int array_bitsize =
2050 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2051
2052 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2053 }
2054 }
4c4b4cd2 2055 }
14f9c5c9
AS
2056
2057 return lookup_pointer_type (elt_type);
2058 }
2059}
2060
2061/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2062 Otherwise, returns either a standard GDB array with bounds set
2063 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2064 GDB array. Returns NULL if ARR is a null fat pointer. */
2065
d2e4a39e
AS
2066struct value *
2067ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2068{
df407dfe 2069 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2070 {
d2e4a39e 2071 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2072
14f9c5c9 2073 if (arrType == NULL)
4c4b4cd2 2074 return NULL;
14f9c5c9
AS
2075 return value_cast (arrType, value_copy (desc_data (arr)));
2076 }
ad82864c
JB
2077 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2078 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2079 else
2080 return arr;
2081}
2082
2083/* If ARR does not represent an array, returns ARR unchanged.
2084 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2085 be ARR itself if it already is in the proper form). */
2086
720d1a40 2087struct value *
d2e4a39e 2088ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2089{
df407dfe 2090 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2091 {
d2e4a39e 2092 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2093
14f9c5c9 2094 if (arrVal == NULL)
323e0a4a 2095 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2096 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2097 return value_ind (arrVal);
2098 }
ad82864c
JB
2099 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2100 return decode_constrained_packed_array (arr);
d2e4a39e 2101 else
14f9c5c9
AS
2102 return arr;
2103}
2104
2105/* If TYPE represents a GNAT array type, return it translated to an
2106 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2107 packing). For other types, is the identity. */
2108
d2e4a39e
AS
2109struct type *
2110ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2111{
ad82864c
JB
2112 if (ada_is_constrained_packed_array_type (type))
2113 return decode_constrained_packed_array_type (type);
17280b9f
UW
2114
2115 if (ada_is_array_descriptor_type (type))
556bdfd4 2116 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2117
2118 return type;
14f9c5c9
AS
2119}
2120
4c4b4cd2
PH
2121/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2122
ad82864c
JB
2123static int
2124ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2125{
2126 if (type == NULL)
2127 return 0;
4c4b4cd2 2128 type = desc_base_type (type);
61ee279c 2129 type = ada_check_typedef (type);
d2e4a39e 2130 return
14f9c5c9
AS
2131 ada_type_name (type) != NULL
2132 && strstr (ada_type_name (type), "___XP") != NULL;
2133}
2134
ad82864c
JB
2135/* Non-zero iff TYPE represents a standard GNAT constrained
2136 packed-array type. */
2137
2138int
2139ada_is_constrained_packed_array_type (struct type *type)
2140{
2141 return ada_is_packed_array_type (type)
2142 && !ada_is_array_descriptor_type (type);
2143}
2144
2145/* Non-zero iff TYPE represents an array descriptor for a
2146 unconstrained packed-array type. */
2147
2148static int
2149ada_is_unconstrained_packed_array_type (struct type *type)
2150{
2151 return ada_is_packed_array_type (type)
2152 && ada_is_array_descriptor_type (type);
2153}
2154
2155/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2156 return the size of its elements in bits. */
2157
2158static long
2159decode_packed_array_bitsize (struct type *type)
2160{
0d5cff50
DE
2161 const char *raw_name;
2162 const char *tail;
ad82864c
JB
2163 long bits;
2164
720d1a40
JB
2165 /* Access to arrays implemented as fat pointers are encoded as a typedef
2166 of the fat pointer type. We need the name of the fat pointer type
2167 to do the decoding, so strip the typedef layer. */
2168 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2169 type = ada_typedef_target_type (type);
2170
2171 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2172 if (!raw_name)
2173 raw_name = ada_type_name (desc_base_type (type));
2174
2175 if (!raw_name)
2176 return 0;
2177
2178 tail = strstr (raw_name, "___XP");
720d1a40 2179 gdb_assert (tail != NULL);
ad82864c
JB
2180
2181 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2182 {
2183 lim_warning
2184 (_("could not understand bit size information on packed array"));
2185 return 0;
2186 }
2187
2188 return bits;
2189}
2190
14f9c5c9
AS
2191/* Given that TYPE is a standard GDB array type with all bounds filled
2192 in, and that the element size of its ultimate scalar constituents
2193 (that is, either its elements, or, if it is an array of arrays, its
2194 elements' elements, etc.) is *ELT_BITS, return an identical type,
2195 but with the bit sizes of its elements (and those of any
2196 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2197 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2198 in bits.
2199
2200 Note that, for arrays whose index type has an XA encoding where
2201 a bound references a record discriminant, getting that discriminant,
2202 and therefore the actual value of that bound, is not possible
2203 because none of the given parameters gives us access to the record.
2204 This function assumes that it is OK in the context where it is being
2205 used to return an array whose bounds are still dynamic and where
2206 the length is arbitrary. */
4c4b4cd2 2207
d2e4a39e 2208static struct type *
ad82864c 2209constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2210{
d2e4a39e
AS
2211 struct type *new_elt_type;
2212 struct type *new_type;
99b1c762
JB
2213 struct type *index_type_desc;
2214 struct type *index_type;
14f9c5c9
AS
2215 LONGEST low_bound, high_bound;
2216
61ee279c 2217 type = ada_check_typedef (type);
14f9c5c9
AS
2218 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2219 return type;
2220
99b1c762
JB
2221 index_type_desc = ada_find_parallel_type (type, "___XA");
2222 if (index_type_desc)
2223 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2224 NULL);
2225 else
2226 index_type = TYPE_INDEX_TYPE (type);
2227
e9bb382b 2228 new_type = alloc_type_copy (type);
ad82864c
JB
2229 new_elt_type =
2230 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2231 elt_bits);
99b1c762 2232 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2233 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2234 TYPE_NAME (new_type) = ada_type_name (type);
2235
4a46959e
JB
2236 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2237 && is_dynamic_type (check_typedef (index_type)))
2238 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2239 low_bound = high_bound = 0;
2240 if (high_bound < low_bound)
2241 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2242 else
14f9c5c9
AS
2243 {
2244 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2245 TYPE_LENGTH (new_type) =
4c4b4cd2 2246 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2247 }
2248
876cecd0 2249 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2250 return new_type;
2251}
2252
ad82864c
JB
2253/* The array type encoded by TYPE, where
2254 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2255
d2e4a39e 2256static struct type *
ad82864c 2257decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2258{
0d5cff50 2259 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2260 char *name;
0d5cff50 2261 const char *tail;
d2e4a39e 2262 struct type *shadow_type;
14f9c5c9 2263 long bits;
14f9c5c9 2264
727e3d2e
JB
2265 if (!raw_name)
2266 raw_name = ada_type_name (desc_base_type (type));
2267
2268 if (!raw_name)
2269 return NULL;
2270
2271 name = (char *) alloca (strlen (raw_name) + 1);
2272 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2273 type = desc_base_type (type);
2274
14f9c5c9
AS
2275 memcpy (name, raw_name, tail - raw_name);
2276 name[tail - raw_name] = '\000';
2277
b4ba55a1
JB
2278 shadow_type = ada_find_parallel_type_with_name (type, name);
2279
2280 if (shadow_type == NULL)
14f9c5c9 2281 {
323e0a4a 2282 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2283 return NULL;
2284 }
f168693b 2285 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2286
2287 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2288 {
0963b4bd
MS
2289 lim_warning (_("could not understand bounds "
2290 "information on packed array"));
14f9c5c9
AS
2291 return NULL;
2292 }
d2e4a39e 2293
ad82864c
JB
2294 bits = decode_packed_array_bitsize (type);
2295 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2296}
2297
ad82864c
JB
2298/* Given that ARR is a struct value *indicating a GNAT constrained packed
2299 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2300 standard GDB array type except that the BITSIZEs of the array
2301 target types are set to the number of bits in each element, and the
4c4b4cd2 2302 type length is set appropriately. */
14f9c5c9 2303
d2e4a39e 2304static struct value *
ad82864c 2305decode_constrained_packed_array (struct value *arr)
14f9c5c9 2306{
4c4b4cd2 2307 struct type *type;
14f9c5c9 2308
11aa919a
PMR
2309 /* If our value is a pointer, then dereference it. Likewise if
2310 the value is a reference. Make sure that this operation does not
2311 cause the target type to be fixed, as this would indirectly cause
2312 this array to be decoded. The rest of the routine assumes that
2313 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2314 and "value_ind" routines to perform the dereferencing, as opposed
2315 to using "ada_coerce_ref" or "ada_value_ind". */
2316 arr = coerce_ref (arr);
828292f2 2317 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2318 arr = value_ind (arr);
4c4b4cd2 2319
ad82864c 2320 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2321 if (type == NULL)
2322 {
323e0a4a 2323 error (_("can't unpack array"));
14f9c5c9
AS
2324 return NULL;
2325 }
61ee279c 2326
50810684 2327 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2328 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2329 {
2330 /* This is a (right-justified) modular type representing a packed
2331 array with no wrapper. In order to interpret the value through
2332 the (left-justified) packed array type we just built, we must
2333 first left-justify it. */
2334 int bit_size, bit_pos;
2335 ULONGEST mod;
2336
df407dfe 2337 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2338 bit_size = 0;
2339 while (mod > 0)
2340 {
2341 bit_size += 1;
2342 mod >>= 1;
2343 }
df407dfe 2344 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2345 arr = ada_value_primitive_packed_val (arr, NULL,
2346 bit_pos / HOST_CHAR_BIT,
2347 bit_pos % HOST_CHAR_BIT,
2348 bit_size,
2349 type);
2350 }
2351
4c4b4cd2 2352 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2353}
2354
2355
2356/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2357 given in IND. ARR must be a simple array. */
14f9c5c9 2358
d2e4a39e
AS
2359static struct value *
2360value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2361{
2362 int i;
2363 int bits, elt_off, bit_off;
2364 long elt_total_bit_offset;
d2e4a39e
AS
2365 struct type *elt_type;
2366 struct value *v;
14f9c5c9
AS
2367
2368 bits = 0;
2369 elt_total_bit_offset = 0;
df407dfe 2370 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2371 for (i = 0; i < arity; i += 1)
14f9c5c9 2372 {
d2e4a39e 2373 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2374 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2375 error
0963b4bd
MS
2376 (_("attempt to do packed indexing of "
2377 "something other than a packed array"));
14f9c5c9 2378 else
4c4b4cd2
PH
2379 {
2380 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2381 LONGEST lowerbound, upperbound;
2382 LONGEST idx;
2383
2384 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2385 {
323e0a4a 2386 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2387 lowerbound = upperbound = 0;
2388 }
2389
3cb382c9 2390 idx = pos_atr (ind[i]);
4c4b4cd2 2391 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2392 lim_warning (_("packed array index %ld out of bounds"),
2393 (long) idx);
4c4b4cd2
PH
2394 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2395 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2396 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2397 }
14f9c5c9
AS
2398 }
2399 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2400 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2401
2402 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2403 bits, elt_type);
14f9c5c9
AS
2404 return v;
2405}
2406
4c4b4cd2 2407/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2408
2409static int
d2e4a39e 2410has_negatives (struct type *type)
14f9c5c9 2411{
d2e4a39e
AS
2412 switch (TYPE_CODE (type))
2413 {
2414 default:
2415 return 0;
2416 case TYPE_CODE_INT:
2417 return !TYPE_UNSIGNED (type);
2418 case TYPE_CODE_RANGE:
2419 return TYPE_LOW_BOUND (type) < 0;
2420 }
14f9c5c9 2421}
d2e4a39e 2422
f93fca70 2423/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
5b639dea 2424 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
f93fca70 2425 the unpacked buffer.
14f9c5c9 2426
5b639dea
JB
2427 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2428 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2429
f93fca70
JB
2430 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2431 zero otherwise.
14f9c5c9 2432
f93fca70 2433 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
a1c95e6b 2434
f93fca70
JB
2435 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2436
2437static void
2438ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2439 gdb_byte *unpacked, int unpacked_len,
2440 int is_big_endian, int is_signed_type,
2441 int is_scalar)
2442{
a1c95e6b
JB
2443 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2444 int src_idx; /* Index into the source area */
2445 int src_bytes_left; /* Number of source bytes left to process. */
2446 int srcBitsLeft; /* Number of source bits left to move */
2447 int unusedLS; /* Number of bits in next significant
2448 byte of source that are unused */
2449
a1c95e6b
JB
2450 int unpacked_idx; /* Index into the unpacked buffer */
2451 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2452
4c4b4cd2 2453 unsigned long accum; /* Staging area for bits being transferred */
a1c95e6b 2454 int accumSize; /* Number of meaningful bits in accum */
14f9c5c9 2455 unsigned char sign;
a1c95e6b 2456
4c4b4cd2
PH
2457 /* Transmit bytes from least to most significant; delta is the direction
2458 the indices move. */
f93fca70 2459 int delta = is_big_endian ? -1 : 1;
14f9c5c9 2460
5b639dea
JB
2461 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2462 bits from SRC. .*/
2463 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2464 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2465 bit_size, unpacked_len);
2466
14f9c5c9 2467 srcBitsLeft = bit_size;
086ca51f 2468 src_bytes_left = src_len;
f93fca70 2469 unpacked_bytes_left = unpacked_len;
14f9c5c9 2470 sign = 0;
f93fca70
JB
2471
2472 if (is_big_endian)
14f9c5c9 2473 {
086ca51f 2474 src_idx = src_len - 1;
f93fca70
JB
2475 if (is_signed_type
2476 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2477 sign = ~0;
d2e4a39e
AS
2478
2479 unusedLS =
4c4b4cd2
PH
2480 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2481 % HOST_CHAR_BIT;
14f9c5c9 2482
f93fca70
JB
2483 if (is_scalar)
2484 {
2485 accumSize = 0;
2486 unpacked_idx = unpacked_len - 1;
2487 }
2488 else
2489 {
4c4b4cd2
PH
2490 /* Non-scalar values must be aligned at a byte boundary... */
2491 accumSize =
2492 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2493 /* ... And are placed at the beginning (most-significant) bytes
2494 of the target. */
086ca51f
JB
2495 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2496 unpacked_bytes_left = unpacked_idx + 1;
f93fca70 2497 }
14f9c5c9 2498 }
d2e4a39e 2499 else
14f9c5c9
AS
2500 {
2501 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2502
086ca51f 2503 src_idx = unpacked_idx = 0;
14f9c5c9
AS
2504 unusedLS = bit_offset;
2505 accumSize = 0;
2506
f93fca70 2507 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2508 sign = ~0;
14f9c5c9 2509 }
d2e4a39e 2510
14f9c5c9 2511 accum = 0;
086ca51f 2512 while (src_bytes_left > 0)
14f9c5c9
AS
2513 {
2514 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2515 part of the value. */
d2e4a39e 2516 unsigned int unusedMSMask =
4c4b4cd2
PH
2517 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2518 1;
2519 /* Sign-extend bits for this byte. */
14f9c5c9 2520 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2521
d2e4a39e 2522 accum |=
086ca51f 2523 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2524 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2525 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2 2526 {
db297a65 2527 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
4c4b4cd2
PH
2528 accumSize -= HOST_CHAR_BIT;
2529 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2530 unpacked_bytes_left -= 1;
2531 unpacked_idx += delta;
4c4b4cd2 2532 }
14f9c5c9
AS
2533 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2534 unusedLS = 0;
086ca51f
JB
2535 src_bytes_left -= 1;
2536 src_idx += delta;
14f9c5c9 2537 }
086ca51f 2538 while (unpacked_bytes_left > 0)
14f9c5c9
AS
2539 {
2540 accum |= sign << accumSize;
db297a65 2541 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
14f9c5c9 2542 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2543 if (accumSize < 0)
2544 accumSize = 0;
14f9c5c9 2545 accum >>= HOST_CHAR_BIT;
086ca51f
JB
2546 unpacked_bytes_left -= 1;
2547 unpacked_idx += delta;
14f9c5c9 2548 }
f93fca70
JB
2549}
2550
2551/* Create a new value of type TYPE from the contents of OBJ starting
2552 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2553 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2554 assigning through the result will set the field fetched from.
2555 VALADDR is ignored unless OBJ is NULL, in which case,
2556 VALADDR+OFFSET must address the start of storage containing the
2557 packed value. The value returned in this case is never an lval.
2558 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2559
2560struct value *
2561ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2562 long offset, int bit_offset, int bit_size,
2563 struct type *type)
2564{
2565 struct value *v;
bfb1c796 2566 const gdb_byte *src; /* First byte containing data to unpack */
f93fca70 2567 gdb_byte *unpacked;
220475ed 2568 const int is_scalar = is_scalar_type (type);
d0a9e810 2569 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
200069c7 2570 std::unique_ptr<gdb_byte[]> staging;
d0a9e810 2571 int staging_len = 0;
f93fca70
JB
2572
2573 type = ada_check_typedef (type);
2574
d0a9e810 2575 if (obj == NULL)
bfb1c796 2576 src = valaddr + offset;
d0a9e810 2577 else
bfb1c796 2578 src = value_contents (obj) + offset;
d0a9e810
JB
2579
2580 if (is_dynamic_type (type))
2581 {
2582 /* The length of TYPE might by dynamic, so we need to resolve
2583 TYPE in order to know its actual size, which we then use
2584 to create the contents buffer of the value we return.
2585 The difficulty is that the data containing our object is
2586 packed, and therefore maybe not at a byte boundary. So, what
2587 we do, is unpack the data into a byte-aligned buffer, and then
2588 use that buffer as our object's value for resolving the type. */
2589 staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
200069c7 2590 staging.reset (new gdb_byte[staging_len]);
d0a9e810
JB
2591
2592 ada_unpack_from_contents (src, bit_offset, bit_size,
200069c7 2593 staging.get (), staging_len,
d0a9e810
JB
2594 is_big_endian, has_negatives (type),
2595 is_scalar);
200069c7 2596 type = resolve_dynamic_type (type, staging.get (), 0);
0cafa88c
JB
2597 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2598 {
2599 /* This happens when the length of the object is dynamic,
2600 and is actually smaller than the space reserved for it.
2601 For instance, in an array of variant records, the bit_size
2602 we're given is the array stride, which is constant and
2603 normally equal to the maximum size of its element.
2604 But, in reality, each element only actually spans a portion
2605 of that stride. */
2606 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2607 }
d0a9e810
JB
2608 }
2609
f93fca70
JB
2610 if (obj == NULL)
2611 {
2612 v = allocate_value (type);
bfb1c796 2613 src = valaddr + offset;
f93fca70
JB
2614 }
2615 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2616 {
0cafa88c 2617 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
bfb1c796 2618 gdb_byte *buf;
0cafa88c 2619
f93fca70 2620 v = value_at (type, value_address (obj) + offset);
bfb1c796
PA
2621 buf = (gdb_byte *) alloca (src_len);
2622 read_memory (value_address (v), buf, src_len);
2623 src = buf;
f93fca70
JB
2624 }
2625 else
2626 {
2627 v = allocate_value (type);
bfb1c796 2628 src = value_contents (obj) + offset;
f93fca70
JB
2629 }
2630
2631 if (obj != NULL)
2632 {
2633 long new_offset = offset;
2634
2635 set_value_component_location (v, obj);
2636 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2637 set_value_bitsize (v, bit_size);
2638 if (value_bitpos (v) >= HOST_CHAR_BIT)
2639 {
2640 ++new_offset;
2641 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2642 }
2643 set_value_offset (v, new_offset);
2644
2645 /* Also set the parent value. This is needed when trying to
2646 assign a new value (in inferior memory). */
2647 set_value_parent (v, obj);
2648 }
2649 else
2650 set_value_bitsize (v, bit_size);
bfb1c796 2651 unpacked = value_contents_writeable (v);
f93fca70
JB
2652
2653 if (bit_size == 0)
2654 {
2655 memset (unpacked, 0, TYPE_LENGTH (type));
2656 return v;
2657 }
2658
d0a9e810 2659 if (staging != NULL && staging_len == TYPE_LENGTH (type))
f93fca70 2660 {
d0a9e810
JB
2661 /* Small short-cut: If we've unpacked the data into a buffer
2662 of the same size as TYPE's length, then we can reuse that,
2663 instead of doing the unpacking again. */
200069c7 2664 memcpy (unpacked, staging.get (), staging_len);
f93fca70 2665 }
d0a9e810
JB
2666 else
2667 ada_unpack_from_contents (src, bit_offset, bit_size,
2668 unpacked, TYPE_LENGTH (type),
2669 is_big_endian, has_negatives (type), is_scalar);
f93fca70 2670
14f9c5c9
AS
2671 return v;
2672}
d2e4a39e 2673
14f9c5c9
AS
2674/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2675 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2676 not overlap. */
14f9c5c9 2677static void
fc1a4b47 2678move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2679 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2680{
2681 unsigned int accum, mask;
2682 int accum_bits, chunk_size;
2683
2684 target += targ_offset / HOST_CHAR_BIT;
2685 targ_offset %= HOST_CHAR_BIT;
2686 source += src_offset / HOST_CHAR_BIT;
2687 src_offset %= HOST_CHAR_BIT;
50810684 2688 if (bits_big_endian_p)
14f9c5c9
AS
2689 {
2690 accum = (unsigned char) *source;
2691 source += 1;
2692 accum_bits = HOST_CHAR_BIT - src_offset;
2693
d2e4a39e 2694 while (n > 0)
4c4b4cd2
PH
2695 {
2696 int unused_right;
5b4ee69b 2697
4c4b4cd2
PH
2698 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2699 accum_bits += HOST_CHAR_BIT;
2700 source += 1;
2701 chunk_size = HOST_CHAR_BIT - targ_offset;
2702 if (chunk_size > n)
2703 chunk_size = n;
2704 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2705 mask = ((1 << chunk_size) - 1) << unused_right;
2706 *target =
2707 (*target & ~mask)
2708 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2709 n -= chunk_size;
2710 accum_bits -= chunk_size;
2711 target += 1;
2712 targ_offset = 0;
2713 }
14f9c5c9
AS
2714 }
2715 else
2716 {
2717 accum = (unsigned char) *source >> src_offset;
2718 source += 1;
2719 accum_bits = HOST_CHAR_BIT - src_offset;
2720
d2e4a39e 2721 while (n > 0)
4c4b4cd2
PH
2722 {
2723 accum = accum + ((unsigned char) *source << accum_bits);
2724 accum_bits += HOST_CHAR_BIT;
2725 source += 1;
2726 chunk_size = HOST_CHAR_BIT - targ_offset;
2727 if (chunk_size > n)
2728 chunk_size = n;
2729 mask = ((1 << chunk_size) - 1) << targ_offset;
2730 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2731 n -= chunk_size;
2732 accum_bits -= chunk_size;
2733 accum >>= chunk_size;
2734 target += 1;
2735 targ_offset = 0;
2736 }
14f9c5c9
AS
2737 }
2738}
2739
14f9c5c9
AS
2740/* Store the contents of FROMVAL into the location of TOVAL.
2741 Return a new value with the location of TOVAL and contents of
2742 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2743 floating-point or non-scalar types. */
14f9c5c9 2744
d2e4a39e
AS
2745static struct value *
2746ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2747{
df407dfe
AC
2748 struct type *type = value_type (toval);
2749 int bits = value_bitsize (toval);
14f9c5c9 2750
52ce6436
PH
2751 toval = ada_coerce_ref (toval);
2752 fromval = ada_coerce_ref (fromval);
2753
2754 if (ada_is_direct_array_type (value_type (toval)))
2755 toval = ada_coerce_to_simple_array (toval);
2756 if (ada_is_direct_array_type (value_type (fromval)))
2757 fromval = ada_coerce_to_simple_array (fromval);
2758
88e3b34b 2759 if (!deprecated_value_modifiable (toval))
323e0a4a 2760 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2761
d2e4a39e 2762 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2763 && bits > 0
d2e4a39e 2764 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2765 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2766 {
df407dfe
AC
2767 int len = (value_bitpos (toval)
2768 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2769 int from_size;
224c3ddb 2770 gdb_byte *buffer = (gdb_byte *) alloca (len);
d2e4a39e 2771 struct value *val;
42ae5230 2772 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2773
2774 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2775 fromval = value_cast (type, fromval);
14f9c5c9 2776
52ce6436 2777 read_memory (to_addr, buffer, len);
aced2898
PH
2778 from_size = value_bitsize (fromval);
2779 if (from_size == 0)
2780 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2781 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2782 move_bits (buffer, value_bitpos (toval),
50810684 2783 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2784 else
50810684
UW
2785 move_bits (buffer, value_bitpos (toval),
2786 value_contents (fromval), 0, bits, 0);
972daa01 2787 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2788
14f9c5c9 2789 val = value_copy (toval);
0fd88904 2790 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2791 TYPE_LENGTH (type));
04624583 2792 deprecated_set_value_type (val, type);
d2e4a39e 2793
14f9c5c9
AS
2794 return val;
2795 }
2796
2797 return value_assign (toval, fromval);
2798}
2799
2800
7c512744
JB
2801/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2802 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2803 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2804 COMPONENT, and not the inferior's memory. The current contents
2805 of COMPONENT are ignored.
2806
2807 Although not part of the initial design, this function also works
2808 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2809 had a null address, and COMPONENT had an address which is equal to
2810 its offset inside CONTAINER. */
2811
52ce6436
PH
2812static void
2813value_assign_to_component (struct value *container, struct value *component,
2814 struct value *val)
2815{
2816 LONGEST offset_in_container =
42ae5230 2817 (LONGEST) (value_address (component) - value_address (container));
7c512744 2818 int bit_offset_in_container =
52ce6436
PH
2819 value_bitpos (component) - value_bitpos (container);
2820 int bits;
7c512744 2821
52ce6436
PH
2822 val = value_cast (value_type (component), val);
2823
2824 if (value_bitsize (component) == 0)
2825 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2826 else
2827 bits = value_bitsize (component);
2828
50810684 2829 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
7c512744 2830 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436
PH
2831 value_bitpos (container) + bit_offset_in_container,
2832 value_contents (val),
2833 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2834 bits, 1);
52ce6436 2835 else
7c512744 2836 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2837 value_bitpos (container) + bit_offset_in_container,
50810684 2838 value_contents (val), 0, bits, 0);
7c512744
JB
2839}
2840
4c4b4cd2
PH
2841/* The value of the element of array ARR at the ARITY indices given in IND.
2842 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2843 thereto. */
2844
d2e4a39e
AS
2845struct value *
2846ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2847{
2848 int k;
d2e4a39e
AS
2849 struct value *elt;
2850 struct type *elt_type;
14f9c5c9
AS
2851
2852 elt = ada_coerce_to_simple_array (arr);
2853
df407dfe 2854 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2855 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2856 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2857 return value_subscript_packed (elt, arity, ind);
2858
2859 for (k = 0; k < arity; k += 1)
2860 {
2861 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2862 error (_("too many subscripts (%d expected)"), k);
2497b498 2863 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2864 }
2865 return elt;
2866}
2867
deede10c
JB
2868/* Assuming ARR is a pointer to a GDB array, the value of the element
2869 of *ARR at the ARITY indices given in IND.
919e6dbe
PMR
2870 Does not read the entire array into memory.
2871
2872 Note: Unlike what one would expect, this function is used instead of
2873 ada_value_subscript for basically all non-packed array types. The reason
2874 for this is that a side effect of doing our own pointer arithmetics instead
2875 of relying on value_subscript is that there is no implicit typedef peeling.
2876 This is important for arrays of array accesses, where it allows us to
2877 preserve the fact that the array's element is an array access, where the
2878 access part os encoded in a typedef layer. */
14f9c5c9 2879
2c0b251b 2880static struct value *
deede10c 2881ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2882{
2883 int k;
919e6dbe 2884 struct value *array_ind = ada_value_ind (arr);
deede10c 2885 struct type *type
919e6dbe
PMR
2886 = check_typedef (value_enclosing_type (array_ind));
2887
2888 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2889 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2890 return value_subscript_packed (array_ind, arity, ind);
14f9c5c9
AS
2891
2892 for (k = 0; k < arity; k += 1)
2893 {
2894 LONGEST lwb, upb;
aa715135 2895 struct value *lwb_value;
14f9c5c9
AS
2896
2897 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2898 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2899 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2900 value_copy (arr));
14f9c5c9 2901 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2902 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2903 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2904 type = TYPE_TARGET_TYPE (type);
2905 }
2906
2907 return value_ind (arr);
2908}
2909
0b5d8877 2910/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2911 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2912 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2913 this array is LOW, as per Ada rules. */
0b5d8877 2914static struct value *
f5938064
JG
2915ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2916 int low, int high)
0b5d8877 2917{
b0dd7688 2918 struct type *type0 = ada_check_typedef (type);
aa715135 2919 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2920 struct type *index_type
aa715135 2921 = create_static_range_type (NULL, base_index_type, low, high);
6c038f32 2922 struct type *slice_type =
b0dd7688 2923 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
aa715135
JG
2924 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2925 LONGEST base_low_pos, low_pos;
2926 CORE_ADDR base;
2927
2928 if (!discrete_position (base_index_type, low, &low_pos)
2929 || !discrete_position (base_index_type, base_low, &base_low_pos))
2930 {
2931 warning (_("unable to get positions in slice, use bounds instead"));
2932 low_pos = low;
2933 base_low_pos = base_low;
2934 }
5b4ee69b 2935
aa715135
JG
2936 base = value_as_address (array_ptr)
2937 + ((low_pos - base_low_pos)
2938 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2939 return value_at_lazy (slice_type, base);
0b5d8877
PH
2940}
2941
2942
2943static struct value *
2944ada_value_slice (struct value *array, int low, int high)
2945{
b0dd7688 2946 struct type *type = ada_check_typedef (value_type (array));
aa715135 2947 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2948 struct type *index_type
2949 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2950 struct type *slice_type =
0b5d8877 2951 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
aa715135 2952 LONGEST low_pos, high_pos;
5b4ee69b 2953
aa715135
JG
2954 if (!discrete_position (base_index_type, low, &low_pos)
2955 || !discrete_position (base_index_type, high, &high_pos))
2956 {
2957 warning (_("unable to get positions in slice, use bounds instead"));
2958 low_pos = low;
2959 high_pos = high;
2960 }
2961
2962 return value_cast (slice_type,
2963 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2964}
2965
14f9c5c9
AS
2966/* If type is a record type in the form of a standard GNAT array
2967 descriptor, returns the number of dimensions for type. If arr is a
2968 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2969 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2970
2971int
d2e4a39e 2972ada_array_arity (struct type *type)
14f9c5c9
AS
2973{
2974 int arity;
2975
2976 if (type == NULL)
2977 return 0;
2978
2979 type = desc_base_type (type);
2980
2981 arity = 0;
d2e4a39e 2982 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2983 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2984 else
2985 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2986 {
4c4b4cd2 2987 arity += 1;
61ee279c 2988 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2989 }
d2e4a39e 2990
14f9c5c9
AS
2991 return arity;
2992}
2993
2994/* If TYPE is a record type in the form of a standard GNAT array
2995 descriptor or a simple array type, returns the element type for
2996 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2997 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2998
d2e4a39e
AS
2999struct type *
3000ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
3001{
3002 type = desc_base_type (type);
3003
d2e4a39e 3004 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
3005 {
3006 int k;
d2e4a39e 3007 struct type *p_array_type;
14f9c5c9 3008
556bdfd4 3009 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
3010
3011 k = ada_array_arity (type);
3012 if (k == 0)
4c4b4cd2 3013 return NULL;
d2e4a39e 3014
4c4b4cd2 3015 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 3016 if (nindices >= 0 && k > nindices)
4c4b4cd2 3017 k = nindices;
d2e4a39e 3018 while (k > 0 && p_array_type != NULL)
4c4b4cd2 3019 {
61ee279c 3020 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
3021 k -= 1;
3022 }
14f9c5c9
AS
3023 return p_array_type;
3024 }
3025 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3026 {
3027 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
3028 {
3029 type = TYPE_TARGET_TYPE (type);
3030 nindices -= 1;
3031 }
14f9c5c9
AS
3032 return type;
3033 }
3034
3035 return NULL;
3036}
3037
4c4b4cd2 3038/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
3039 Does not examine memory. Throws an error if N is invalid or TYPE
3040 is not an array type. NAME is the name of the Ada attribute being
3041 evaluated ('range, 'first, 'last, or 'length); it is used in building
3042 the error message. */
14f9c5c9 3043
1eea4ebd
UW
3044static struct type *
3045ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 3046{
4c4b4cd2
PH
3047 struct type *result_type;
3048
14f9c5c9
AS
3049 type = desc_base_type (type);
3050
1eea4ebd
UW
3051 if (n < 0 || n > ada_array_arity (type))
3052 error (_("invalid dimension number to '%s"), name);
14f9c5c9 3053
4c4b4cd2 3054 if (ada_is_simple_array_type (type))
14f9c5c9
AS
3055 {
3056 int i;
3057
3058 for (i = 1; i < n; i += 1)
4c4b4cd2 3059 type = TYPE_TARGET_TYPE (type);
262452ec 3060 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
3061 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3062 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 3063 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
3064 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3065 result_type = NULL;
14f9c5c9 3066 }
d2e4a39e 3067 else
1eea4ebd
UW
3068 {
3069 result_type = desc_index_type (desc_bounds_type (type), n);
3070 if (result_type == NULL)
3071 error (_("attempt to take bound of something that is not an array"));
3072 }
3073
3074 return result_type;
14f9c5c9
AS
3075}
3076
3077/* Given that arr is an array type, returns the lower bound of the
3078 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 3079 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
3080 array-descriptor type. It works for other arrays with bounds supplied
3081 by run-time quantities other than discriminants. */
14f9c5c9 3082
abb68b3e 3083static LONGEST
fb5e3d5c 3084ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 3085{
8a48ac95 3086 struct type *type, *index_type_desc, *index_type;
1ce677a4 3087 int i;
262452ec
JK
3088
3089 gdb_assert (which == 0 || which == 1);
14f9c5c9 3090
ad82864c
JB
3091 if (ada_is_constrained_packed_array_type (arr_type))
3092 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 3093
4c4b4cd2 3094 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 3095 return (LONGEST) - which;
14f9c5c9
AS
3096
3097 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3098 type = TYPE_TARGET_TYPE (arr_type);
3099 else
3100 type = arr_type;
3101
bafffb51
JB
3102 if (TYPE_FIXED_INSTANCE (type))
3103 {
3104 /* The array has already been fixed, so we do not need to
3105 check the parallel ___XA type again. That encoding has
3106 already been applied, so ignore it now. */
3107 index_type_desc = NULL;
3108 }
3109 else
3110 {
3111 index_type_desc = ada_find_parallel_type (type, "___XA");
3112 ada_fixup_array_indexes_type (index_type_desc);
3113 }
3114
262452ec 3115 if (index_type_desc != NULL)
28c85d6c
JB
3116 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3117 NULL);
262452ec 3118 else
8a48ac95
JB
3119 {
3120 struct type *elt_type = check_typedef (type);
3121
3122 for (i = 1; i < n; i++)
3123 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3124
3125 index_type = TYPE_INDEX_TYPE (elt_type);
3126 }
262452ec 3127
43bbcdc2
PH
3128 return
3129 (LONGEST) (which == 0
3130 ? ada_discrete_type_low_bound (index_type)
3131 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3132}
3133
3134/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3135 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3136 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3137 supplied by run-time quantities other than discriminants. */
14f9c5c9 3138
1eea4ebd 3139static LONGEST
4dc81987 3140ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3141{
eb479039
JB
3142 struct type *arr_type;
3143
3144 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3145 arr = value_ind (arr);
3146 arr_type = value_enclosing_type (arr);
14f9c5c9 3147
ad82864c
JB
3148 if (ada_is_constrained_packed_array_type (arr_type))
3149 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3150 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3151 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3152 else
1eea4ebd 3153 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3154}
3155
3156/* Given that arr is an array value, returns the length of the
3157 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3158 supplied by run-time quantities other than discriminants.
3159 Does not work for arrays indexed by enumeration types with representation
3160 clauses at the moment. */
14f9c5c9 3161
1eea4ebd 3162static LONGEST
d2e4a39e 3163ada_array_length (struct value *arr, int n)
14f9c5c9 3164{
aa715135
JG
3165 struct type *arr_type, *index_type;
3166 int low, high;
eb479039
JB
3167
3168 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3169 arr = value_ind (arr);
3170 arr_type = value_enclosing_type (arr);
14f9c5c9 3171
ad82864c
JB
3172 if (ada_is_constrained_packed_array_type (arr_type))
3173 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3174
4c4b4cd2 3175 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3176 {
3177 low = ada_array_bound_from_type (arr_type, n, 0);
3178 high = ada_array_bound_from_type (arr_type, n, 1);
3179 }
14f9c5c9 3180 else
aa715135
JG
3181 {
3182 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3183 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3184 }
3185
f168693b 3186 arr_type = check_typedef (arr_type);
aa715135
JG
3187 index_type = TYPE_INDEX_TYPE (arr_type);
3188 if (index_type != NULL)
3189 {
3190 struct type *base_type;
3191 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3192 base_type = TYPE_TARGET_TYPE (index_type);
3193 else
3194 base_type = index_type;
3195
3196 low = pos_atr (value_from_longest (base_type, low));
3197 high = pos_atr (value_from_longest (base_type, high));
3198 }
3199 return high - low + 1;
4c4b4cd2
PH
3200}
3201
3202/* An empty array whose type is that of ARR_TYPE (an array type),
3203 with bounds LOW to LOW-1. */
3204
3205static struct value *
3206empty_array (struct type *arr_type, int low)
3207{
b0dd7688 3208 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3209 struct type *index_type
3210 = create_static_range_type
3211 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3212 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3213
0b5d8877 3214 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3215}
14f9c5c9 3216\f
d2e4a39e 3217
4c4b4cd2 3218 /* Name resolution */
14f9c5c9 3219
4c4b4cd2
PH
3220/* The "decoded" name for the user-definable Ada operator corresponding
3221 to OP. */
14f9c5c9 3222
d2e4a39e 3223static const char *
4c4b4cd2 3224ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3225{
3226 int i;
3227
4c4b4cd2 3228 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3229 {
3230 if (ada_opname_table[i].op == op)
4c4b4cd2 3231 return ada_opname_table[i].decoded;
14f9c5c9 3232 }
323e0a4a 3233 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3234}
3235
3236
4c4b4cd2
PH
3237/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3238 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3239 undefined namespace) and converts operators that are
3240 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3241 non-null, it provides a preferred result type [at the moment, only
3242 type void has any effect---causing procedures to be preferred over
3243 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3244 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3245
4c4b4cd2
PH
3246static void
3247resolve (struct expression **expp, int void_context_p)
14f9c5c9 3248{
30b15541
UW
3249 struct type *context_type = NULL;
3250 int pc = 0;
3251
3252 if (void_context_p)
3253 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3254
3255 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3256}
3257
4c4b4cd2
PH
3258/* Resolve the operator of the subexpression beginning at
3259 position *POS of *EXPP. "Resolving" consists of replacing
3260 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3261 with their resolutions, replacing built-in operators with
3262 function calls to user-defined operators, where appropriate, and,
3263 when DEPROCEDURE_P is non-zero, converting function-valued variables
3264 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3265 are as in ada_resolve, above. */
14f9c5c9 3266
d2e4a39e 3267static struct value *
4c4b4cd2 3268resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 3269 struct type *context_type)
14f9c5c9
AS
3270{
3271 int pc = *pos;
3272 int i;
4c4b4cd2 3273 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3274 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3275 struct value **argvec; /* Vector of operand types (alloca'ed). */
3276 int nargs; /* Number of operands. */
52ce6436 3277 int oplen;
14f9c5c9
AS
3278
3279 argvec = NULL;
3280 nargs = 0;
3281 exp = *expp;
3282
52ce6436
PH
3283 /* Pass one: resolve operands, saving their types and updating *pos,
3284 if needed. */
14f9c5c9
AS
3285 switch (op)
3286 {
4c4b4cd2
PH
3287 case OP_FUNCALL:
3288 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3289 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3290 *pos += 7;
4c4b4cd2
PH
3291 else
3292 {
3293 *pos += 3;
3294 resolve_subexp (expp, pos, 0, NULL);
3295 }
3296 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3297 break;
3298
14f9c5c9 3299 case UNOP_ADDR:
4c4b4cd2
PH
3300 *pos += 1;
3301 resolve_subexp (expp, pos, 0, NULL);
3302 break;
3303
52ce6436
PH
3304 case UNOP_QUAL:
3305 *pos += 3;
17466c1a 3306 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3307 break;
3308
52ce6436 3309 case OP_ATR_MODULUS:
4c4b4cd2
PH
3310 case OP_ATR_SIZE:
3311 case OP_ATR_TAG:
4c4b4cd2
PH
3312 case OP_ATR_FIRST:
3313 case OP_ATR_LAST:
3314 case OP_ATR_LENGTH:
3315 case OP_ATR_POS:
3316 case OP_ATR_VAL:
4c4b4cd2
PH
3317 case OP_ATR_MIN:
3318 case OP_ATR_MAX:
52ce6436
PH
3319 case TERNOP_IN_RANGE:
3320 case BINOP_IN_BOUNDS:
3321 case UNOP_IN_RANGE:
3322 case OP_AGGREGATE:
3323 case OP_OTHERS:
3324 case OP_CHOICES:
3325 case OP_POSITIONAL:
3326 case OP_DISCRETE_RANGE:
3327 case OP_NAME:
3328 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3329 *pos += oplen;
14f9c5c9
AS
3330 break;
3331
3332 case BINOP_ASSIGN:
3333 {
4c4b4cd2
PH
3334 struct value *arg1;
3335
3336 *pos += 1;
3337 arg1 = resolve_subexp (expp, pos, 0, NULL);
3338 if (arg1 == NULL)
3339 resolve_subexp (expp, pos, 1, NULL);
3340 else
df407dfe 3341 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3342 break;
14f9c5c9
AS
3343 }
3344
4c4b4cd2 3345 case UNOP_CAST:
4c4b4cd2
PH
3346 *pos += 3;
3347 nargs = 1;
3348 break;
14f9c5c9 3349
4c4b4cd2
PH
3350 case BINOP_ADD:
3351 case BINOP_SUB:
3352 case BINOP_MUL:
3353 case BINOP_DIV:
3354 case BINOP_REM:
3355 case BINOP_MOD:
3356 case BINOP_EXP:
3357 case BINOP_CONCAT:
3358 case BINOP_LOGICAL_AND:
3359 case BINOP_LOGICAL_OR:
3360 case BINOP_BITWISE_AND:
3361 case BINOP_BITWISE_IOR:
3362 case BINOP_BITWISE_XOR:
14f9c5c9 3363
4c4b4cd2
PH
3364 case BINOP_EQUAL:
3365 case BINOP_NOTEQUAL:
3366 case BINOP_LESS:
3367 case BINOP_GTR:
3368 case BINOP_LEQ:
3369 case BINOP_GEQ:
14f9c5c9 3370
4c4b4cd2
PH
3371 case BINOP_REPEAT:
3372 case BINOP_SUBSCRIPT:
3373 case BINOP_COMMA:
40c8aaa9
JB
3374 *pos += 1;
3375 nargs = 2;
3376 break;
14f9c5c9 3377
4c4b4cd2
PH
3378 case UNOP_NEG:
3379 case UNOP_PLUS:
3380 case UNOP_LOGICAL_NOT:
3381 case UNOP_ABS:
3382 case UNOP_IND:
3383 *pos += 1;
3384 nargs = 1;
3385 break;
14f9c5c9 3386
4c4b4cd2
PH
3387 case OP_LONG:
3388 case OP_DOUBLE:
3389 case OP_VAR_VALUE:
3390 *pos += 4;
3391 break;
14f9c5c9 3392
4c4b4cd2
PH
3393 case OP_TYPE:
3394 case OP_BOOL:
3395 case OP_LAST:
4c4b4cd2
PH
3396 case OP_INTERNALVAR:
3397 *pos += 3;
3398 break;
14f9c5c9 3399
4c4b4cd2
PH
3400 case UNOP_MEMVAL:
3401 *pos += 3;
3402 nargs = 1;
3403 break;
3404
67f3407f
DJ
3405 case OP_REGISTER:
3406 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3407 break;
3408
4c4b4cd2
PH
3409 case STRUCTOP_STRUCT:
3410 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3411 nargs = 1;
3412 break;
3413
4c4b4cd2 3414 case TERNOP_SLICE:
4c4b4cd2
PH
3415 *pos += 1;
3416 nargs = 3;
3417 break;
3418
52ce6436 3419 case OP_STRING:
14f9c5c9 3420 break;
4c4b4cd2
PH
3421
3422 default:
323e0a4a 3423 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3424 }
3425
8d749320 3426 argvec = XALLOCAVEC (struct value *, nargs + 1);
4c4b4cd2
PH
3427 for (i = 0; i < nargs; i += 1)
3428 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3429 argvec[i] = NULL;
3430 exp = *expp;
3431
3432 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3433 switch (op)
3434 {
3435 default:
3436 break;
3437
14f9c5c9 3438 case OP_VAR_VALUE:
4c4b4cd2 3439 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3440 {
d12307c1 3441 struct block_symbol *candidates;
76a01679
JB
3442 int n_candidates;
3443
3444 n_candidates =
3445 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3446 (exp->elts[pc + 2].symbol),
3447 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3448 &candidates);
76a01679
JB
3449
3450 if (n_candidates > 1)
3451 {
3452 /* Types tend to get re-introduced locally, so if there
3453 are any local symbols that are not types, first filter
3454 out all types. */
3455 int j;
3456 for (j = 0; j < n_candidates; j += 1)
d12307c1 3457 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3458 {
3459 case LOC_REGISTER:
3460 case LOC_ARG:
3461 case LOC_REF_ARG:
76a01679
JB
3462 case LOC_REGPARM_ADDR:
3463 case LOC_LOCAL:
76a01679 3464 case LOC_COMPUTED:
76a01679
JB
3465 goto FoundNonType;
3466 default:
3467 break;
3468 }
3469 FoundNonType:
3470 if (j < n_candidates)
3471 {
3472 j = 0;
3473 while (j < n_candidates)
3474 {
d12307c1 3475 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3476 {
3477 candidates[j] = candidates[n_candidates - 1];
3478 n_candidates -= 1;
3479 }
3480 else
3481 j += 1;
3482 }
3483 }
3484 }
3485
3486 if (n_candidates == 0)
323e0a4a 3487 error (_("No definition found for %s"),
76a01679
JB
3488 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3489 else if (n_candidates == 1)
3490 i = 0;
3491 else if (deprocedure_p
3492 && !is_nonfunction (candidates, n_candidates))
3493 {
06d5cf63
JB
3494 i = ada_resolve_function
3495 (candidates, n_candidates, NULL, 0,
3496 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3497 context_type);
76a01679 3498 if (i < 0)
323e0a4a 3499 error (_("Could not find a match for %s"),
76a01679
JB
3500 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3501 }
3502 else
3503 {
323e0a4a 3504 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3505 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3506 user_select_syms (candidates, n_candidates, 1);
3507 i = 0;
3508 }
3509
3510 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3511 exp->elts[pc + 2].symbol = candidates[i].symbol;
1265e4aa
JB
3512 if (innermost_block == NULL
3513 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3514 innermost_block = candidates[i].block;
3515 }
3516
3517 if (deprocedure_p
3518 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3519 == TYPE_CODE_FUNC))
3520 {
3521 replace_operator_with_call (expp, pc, 0, 0,
3522 exp->elts[pc + 2].symbol,
3523 exp->elts[pc + 1].block);
3524 exp = *expp;
3525 }
14f9c5c9
AS
3526 break;
3527
3528 case OP_FUNCALL:
3529 {
4c4b4cd2 3530 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3531 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3532 {
d12307c1 3533 struct block_symbol *candidates;
4c4b4cd2
PH
3534 int n_candidates;
3535
3536 n_candidates =
76a01679
JB
3537 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3538 (exp->elts[pc + 5].symbol),
3539 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3540 &candidates);
4c4b4cd2
PH
3541 if (n_candidates == 1)
3542 i = 0;
3543 else
3544 {
06d5cf63
JB
3545 i = ada_resolve_function
3546 (candidates, n_candidates,
3547 argvec, nargs,
3548 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3549 context_type);
4c4b4cd2 3550 if (i < 0)
323e0a4a 3551 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3552 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3553 }
3554
3555 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3556 exp->elts[pc + 5].symbol = candidates[i].symbol;
1265e4aa
JB
3557 if (innermost_block == NULL
3558 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3559 innermost_block = candidates[i].block;
3560 }
14f9c5c9
AS
3561 }
3562 break;
3563 case BINOP_ADD:
3564 case BINOP_SUB:
3565 case BINOP_MUL:
3566 case BINOP_DIV:
3567 case BINOP_REM:
3568 case BINOP_MOD:
3569 case BINOP_CONCAT:
3570 case BINOP_BITWISE_AND:
3571 case BINOP_BITWISE_IOR:
3572 case BINOP_BITWISE_XOR:
3573 case BINOP_EQUAL:
3574 case BINOP_NOTEQUAL:
3575 case BINOP_LESS:
3576 case BINOP_GTR:
3577 case BINOP_LEQ:
3578 case BINOP_GEQ:
3579 case BINOP_EXP:
3580 case UNOP_NEG:
3581 case UNOP_PLUS:
3582 case UNOP_LOGICAL_NOT:
3583 case UNOP_ABS:
3584 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3585 {
d12307c1 3586 struct block_symbol *candidates;
4c4b4cd2
PH
3587 int n_candidates;
3588
3589 n_candidates =
3590 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3591 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3592 &candidates);
4c4b4cd2 3593 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3594 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3595 if (i < 0)
3596 break;
3597
d12307c1
PMR
3598 replace_operator_with_call (expp, pc, nargs, 1,
3599 candidates[i].symbol,
3600 candidates[i].block);
4c4b4cd2
PH
3601 exp = *expp;
3602 }
14f9c5c9 3603 break;
4c4b4cd2
PH
3604
3605 case OP_TYPE:
b3dbf008 3606 case OP_REGISTER:
4c4b4cd2 3607 return NULL;
14f9c5c9
AS
3608 }
3609
3610 *pos = pc;
3611 return evaluate_subexp_type (exp, pos);
3612}
3613
3614/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3615 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3616 a non-pointer. */
14f9c5c9 3617/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3618 liberal. */
14f9c5c9
AS
3619
3620static int
4dc81987 3621ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3622{
61ee279c
PH
3623 ftype = ada_check_typedef (ftype);
3624 atype = ada_check_typedef (atype);
14f9c5c9
AS
3625
3626 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3627 ftype = TYPE_TARGET_TYPE (ftype);
3628 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3629 atype = TYPE_TARGET_TYPE (atype);
3630
d2e4a39e 3631 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3632 {
3633 default:
5b3d5b7d 3634 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3635 case TYPE_CODE_PTR:
3636 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3637 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3638 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3639 else
1265e4aa
JB
3640 return (may_deref
3641 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3642 case TYPE_CODE_INT:
3643 case TYPE_CODE_ENUM:
3644 case TYPE_CODE_RANGE:
3645 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3646 {
3647 case TYPE_CODE_INT:
3648 case TYPE_CODE_ENUM:
3649 case TYPE_CODE_RANGE:
3650 return 1;
3651 default:
3652 return 0;
3653 }
14f9c5c9
AS
3654
3655 case TYPE_CODE_ARRAY:
d2e4a39e 3656 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3657 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3658
3659 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3660 if (ada_is_array_descriptor_type (ftype))
3661 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3662 || ada_is_array_descriptor_type (atype));
14f9c5c9 3663 else
4c4b4cd2
PH
3664 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3665 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3666
3667 case TYPE_CODE_UNION:
3668 case TYPE_CODE_FLT:
3669 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3670 }
3671}
3672
3673/* Return non-zero if the formals of FUNC "sufficiently match" the
3674 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3675 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3676 argument function. */
14f9c5c9
AS
3677
3678static int
d2e4a39e 3679ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3680{
3681 int i;
d2e4a39e 3682 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3683
1265e4aa
JB
3684 if (SYMBOL_CLASS (func) == LOC_CONST
3685 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3686 return (n_actuals == 0);
3687 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3688 return 0;
3689
3690 if (TYPE_NFIELDS (func_type) != n_actuals)
3691 return 0;
3692
3693 for (i = 0; i < n_actuals; i += 1)
3694 {
4c4b4cd2 3695 if (actuals[i] == NULL)
76a01679
JB
3696 return 0;
3697 else
3698 {
5b4ee69b
MS
3699 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3700 i));
df407dfe 3701 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3702
76a01679
JB
3703 if (!ada_type_match (ftype, atype, 1))
3704 return 0;
3705 }
14f9c5c9
AS
3706 }
3707 return 1;
3708}
3709
3710/* False iff function type FUNC_TYPE definitely does not produce a value
3711 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3712 FUNC_TYPE is not a valid function type with a non-null return type
3713 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3714
3715static int
d2e4a39e 3716return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3717{
d2e4a39e 3718 struct type *return_type;
14f9c5c9
AS
3719
3720 if (func_type == NULL)
3721 return 1;
3722
4c4b4cd2 3723 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3724 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3725 else
18af8284 3726 return_type = get_base_type (func_type);
14f9c5c9
AS
3727 if (return_type == NULL)
3728 return 1;
3729
18af8284 3730 context_type = get_base_type (context_type);
14f9c5c9
AS
3731
3732 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3733 return context_type == NULL || return_type == context_type;
3734 else if (context_type == NULL)
3735 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3736 else
3737 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3738}
3739
3740
4c4b4cd2 3741/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3742 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3743 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3744 that returns that type, then eliminate matches that don't. If
3745 CONTEXT_TYPE is void and there is at least one match that does not
3746 return void, eliminate all matches that do.
3747
14f9c5c9
AS
3748 Asks the user if there is more than one match remaining. Returns -1
3749 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3750 solely for messages. May re-arrange and modify SYMS in
3751 the process; the index returned is for the modified vector. */
14f9c5c9 3752
4c4b4cd2 3753static int
d12307c1 3754ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3755 int nsyms, struct value **args, int nargs,
3756 const char *name, struct type *context_type)
14f9c5c9 3757{
30b15541 3758 int fallback;
14f9c5c9 3759 int k;
4c4b4cd2 3760 int m; /* Number of hits */
14f9c5c9 3761
d2e4a39e 3762 m = 0;
30b15541
UW
3763 /* In the first pass of the loop, we only accept functions matching
3764 context_type. If none are found, we add a second pass of the loop
3765 where every function is accepted. */
3766 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3767 {
3768 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3769 {
d12307c1 3770 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3771
d12307c1 3772 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3773 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3774 {
3775 syms[m] = syms[k];
3776 m += 1;
3777 }
3778 }
14f9c5c9
AS
3779 }
3780
dc5c8746
PMR
3781 /* If we got multiple matches, ask the user which one to use. Don't do this
3782 interactive thing during completion, though, as the purpose of the
3783 completion is providing a list of all possible matches. Prompting the
3784 user to filter it down would be completely unexpected in this case. */
14f9c5c9
AS
3785 if (m == 0)
3786 return -1;
dc5c8746 3787 else if (m > 1 && !parse_completion)
14f9c5c9 3788 {
323e0a4a 3789 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3790 user_select_syms (syms, m, 1);
14f9c5c9
AS
3791 return 0;
3792 }
3793 return 0;
3794}
3795
4c4b4cd2
PH
3796/* Returns true (non-zero) iff decoded name N0 should appear before N1
3797 in a listing of choices during disambiguation (see sort_choices, below).
3798 The idea is that overloadings of a subprogram name from the
3799 same package should sort in their source order. We settle for ordering
3800 such symbols by their trailing number (__N or $N). */
3801
14f9c5c9 3802static int
0d5cff50 3803encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3804{
3805 if (N1 == NULL)
3806 return 0;
3807 else if (N0 == NULL)
3808 return 1;
3809 else
3810 {
3811 int k0, k1;
5b4ee69b 3812
d2e4a39e 3813 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3814 ;
d2e4a39e 3815 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3816 ;
d2e4a39e 3817 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3818 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3819 {
3820 int n0, n1;
5b4ee69b 3821
4c4b4cd2
PH
3822 n0 = k0;
3823 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3824 n0 -= 1;
3825 n1 = k1;
3826 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3827 n1 -= 1;
3828 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3829 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3830 }
14f9c5c9
AS
3831 return (strcmp (N0, N1) < 0);
3832 }
3833}
d2e4a39e 3834
4c4b4cd2
PH
3835/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3836 encoded names. */
3837
d2e4a39e 3838static void
d12307c1 3839sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3840{
4c4b4cd2 3841 int i;
5b4ee69b 3842
d2e4a39e 3843 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3844 {
d12307c1 3845 struct block_symbol sym = syms[i];
14f9c5c9
AS
3846 int j;
3847
d2e4a39e 3848 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3849 {
d12307c1
PMR
3850 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3851 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3852 break;
3853 syms[j + 1] = syms[j];
3854 }
d2e4a39e 3855 syms[j + 1] = sym;
14f9c5c9
AS
3856 }
3857}
3858
d72413e6
PMR
3859/* Whether GDB should display formals and return types for functions in the
3860 overloads selection menu. */
3861static int print_signatures = 1;
3862
3863/* Print the signature for SYM on STREAM according to the FLAGS options. For
3864 all but functions, the signature is just the name of the symbol. For
3865 functions, this is the name of the function, the list of types for formals
3866 and the return type (if any). */
3867
3868static void
3869ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3870 const struct type_print_options *flags)
3871{
3872 struct type *type = SYMBOL_TYPE (sym);
3873
3874 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3875 if (!print_signatures
3876 || type == NULL
3877 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3878 return;
3879
3880 if (TYPE_NFIELDS (type) > 0)
3881 {
3882 int i;
3883
3884 fprintf_filtered (stream, " (");
3885 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3886 {
3887 if (i > 0)
3888 fprintf_filtered (stream, "; ");
3889 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3890 flags);
3891 }
3892 fprintf_filtered (stream, ")");
3893 }
3894 if (TYPE_TARGET_TYPE (type) != NULL
3895 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3896 {
3897 fprintf_filtered (stream, " return ");
3898 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3899 }
3900}
3901
4c4b4cd2
PH
3902/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3903 by asking the user (if necessary), returning the number selected,
3904 and setting the first elements of SYMS items. Error if no symbols
3905 selected. */
14f9c5c9
AS
3906
3907/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3908 to be re-integrated one of these days. */
14f9c5c9
AS
3909
3910int
d12307c1 3911user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3912{
3913 int i;
8d749320 3914 int *chosen = XALLOCAVEC (int , nsyms);
14f9c5c9
AS
3915 int n_chosen;
3916 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3917 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3918
3919 if (max_results < 1)
323e0a4a 3920 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3921 if (nsyms <= 1)
3922 return nsyms;
3923
717d2f5a
JB
3924 if (select_mode == multiple_symbols_cancel)
3925 error (_("\
3926canceled because the command is ambiguous\n\
3927See set/show multiple-symbol."));
3928
3929 /* If select_mode is "all", then return all possible symbols.
3930 Only do that if more than one symbol can be selected, of course.
3931 Otherwise, display the menu as usual. */
3932 if (select_mode == multiple_symbols_all && max_results > 1)
3933 return nsyms;
3934
323e0a4a 3935 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3936 if (max_results > 1)
323e0a4a 3937 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3938
4c4b4cd2 3939 sort_choices (syms, nsyms);
14f9c5c9
AS
3940
3941 for (i = 0; i < nsyms; i += 1)
3942 {
d12307c1 3943 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3944 continue;
3945
d12307c1 3946 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3947 {
76a01679 3948 struct symtab_and_line sal =
d12307c1 3949 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3950
d72413e6
PMR
3951 printf_unfiltered ("[%d] ", i + first_choice);
3952 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3953 &type_print_raw_options);
323e0a4a 3954 if (sal.symtab == NULL)
d72413e6 3955 printf_unfiltered (_(" at <no source file available>:%d\n"),
323e0a4a
AC
3956 sal.line);
3957 else
d72413e6 3958 printf_unfiltered (_(" at %s:%d\n"),
05cba821
JK
3959 symtab_to_filename_for_display (sal.symtab),
3960 sal.line);
4c4b4cd2
PH
3961 continue;
3962 }
d2e4a39e 3963 else
4c4b4cd2
PH
3964 {
3965 int is_enumeral =
d12307c1
PMR
3966 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3967 && SYMBOL_TYPE (syms[i].symbol) != NULL
3968 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3969 struct symtab *symtab = NULL;
3970
d12307c1
PMR
3971 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3972 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3973
d12307c1 3974 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
d72413e6
PMR
3975 {
3976 printf_unfiltered ("[%d] ", i + first_choice);
3977 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3978 &type_print_raw_options);
3979 printf_unfiltered (_(" at %s:%d\n"),
3980 symtab_to_filename_for_display (symtab),
3981 SYMBOL_LINE (syms[i].symbol));
3982 }
76a01679 3983 else if (is_enumeral
d12307c1 3984 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3985 {
a3f17187 3986 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3987 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3988 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3989 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3990 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3991 }
d72413e6
PMR
3992 else
3993 {
3994 printf_unfiltered ("[%d] ", i + first_choice);
3995 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3996 &type_print_raw_options);
3997
3998 if (symtab != NULL)
3999 printf_unfiltered (is_enumeral
4000 ? _(" in %s (enumeral)\n")
4001 : _(" at %s:?\n"),
4002 symtab_to_filename_for_display (symtab));
4003 else
4004 printf_unfiltered (is_enumeral
4005 ? _(" (enumeral)\n")
4006 : _(" at ?\n"));
4007 }
4c4b4cd2 4008 }
14f9c5c9 4009 }
d2e4a39e 4010
14f9c5c9 4011 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 4012 "overload-choice");
14f9c5c9
AS
4013
4014 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 4015 syms[i] = syms[chosen[i]];
14f9c5c9
AS
4016
4017 return n_chosen;
4018}
4019
4020/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 4021 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
4022 order in CHOICES[0 .. N-1], and return N.
4023
4024 The user types choices as a sequence of numbers on one line
4025 separated by blanks, encoding them as follows:
4026
4c4b4cd2 4027 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
4028 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4029 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4030
4c4b4cd2 4031 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
4032
4033 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 4034 prompts (for use with the -f switch). */
14f9c5c9
AS
4035
4036int
d2e4a39e 4037get_selections (int *choices, int n_choices, int max_results,
a121b7c1 4038 int is_all_choice, const char *annotation_suffix)
14f9c5c9 4039{
d2e4a39e 4040 char *args;
a121b7c1 4041 const char *prompt;
14f9c5c9
AS
4042 int n_chosen;
4043 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 4044
14f9c5c9
AS
4045 prompt = getenv ("PS2");
4046 if (prompt == NULL)
0bcd0149 4047 prompt = "> ";
14f9c5c9 4048
0bcd0149 4049 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 4050
14f9c5c9 4051 if (args == NULL)
323e0a4a 4052 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
4053
4054 n_chosen = 0;
76a01679 4055
4c4b4cd2
PH
4056 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4057 order, as given in args. Choices are validated. */
14f9c5c9
AS
4058 while (1)
4059 {
d2e4a39e 4060 char *args2;
14f9c5c9
AS
4061 int choice, j;
4062
0fcd72ba 4063 args = skip_spaces (args);
14f9c5c9 4064 if (*args == '\0' && n_chosen == 0)
323e0a4a 4065 error_no_arg (_("one or more choice numbers"));
14f9c5c9 4066 else if (*args == '\0')
4c4b4cd2 4067 break;
14f9c5c9
AS
4068
4069 choice = strtol (args, &args2, 10);
d2e4a39e 4070 if (args == args2 || choice < 0
4c4b4cd2 4071 || choice > n_choices + first_choice - 1)
323e0a4a 4072 error (_("Argument must be choice number"));
14f9c5c9
AS
4073 args = args2;
4074
d2e4a39e 4075 if (choice == 0)
323e0a4a 4076 error (_("cancelled"));
14f9c5c9
AS
4077
4078 if (choice < first_choice)
4c4b4cd2
PH
4079 {
4080 n_chosen = n_choices;
4081 for (j = 0; j < n_choices; j += 1)
4082 choices[j] = j;
4083 break;
4084 }
14f9c5c9
AS
4085 choice -= first_choice;
4086
d2e4a39e 4087 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
4088 {
4089 }
14f9c5c9
AS
4090
4091 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
4092 {
4093 int k;
5b4ee69b 4094
4c4b4cd2
PH
4095 for (k = n_chosen - 1; k > j; k -= 1)
4096 choices[k + 1] = choices[k];
4097 choices[j + 1] = choice;
4098 n_chosen += 1;
4099 }
14f9c5c9
AS
4100 }
4101
4102 if (n_chosen > max_results)
323e0a4a 4103 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 4104
14f9c5c9
AS
4105 return n_chosen;
4106}
4107
4c4b4cd2
PH
4108/* Replace the operator of length OPLEN at position PC in *EXPP with a call
4109 on the function identified by SYM and BLOCK, and taking NARGS
4110 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
4111
4112static void
d2e4a39e 4113replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 4114 int oplen, struct symbol *sym,
270140bd 4115 const struct block *block)
14f9c5c9
AS
4116{
4117 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 4118 symbol, -oplen for operator being replaced). */
d2e4a39e 4119 struct expression *newexp = (struct expression *)
8c1a34e7 4120 xzalloc (sizeof (struct expression)
4c4b4cd2 4121 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 4122 struct expression *exp = *expp;
14f9c5c9
AS
4123
4124 newexp->nelts = exp->nelts + 7 - oplen;
4125 newexp->language_defn = exp->language_defn;
3489610d 4126 newexp->gdbarch = exp->gdbarch;
14f9c5c9 4127 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 4128 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 4129 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
4130
4131 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4132 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4133
4134 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4135 newexp->elts[pc + 4].block = block;
4136 newexp->elts[pc + 5].symbol = sym;
4137
4138 *expp = newexp;
aacb1f0a 4139 xfree (exp);
d2e4a39e 4140}
14f9c5c9
AS
4141
4142/* Type-class predicates */
4143
4c4b4cd2
PH
4144/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4145 or FLOAT). */
14f9c5c9
AS
4146
4147static int
d2e4a39e 4148numeric_type_p (struct type *type)
14f9c5c9
AS
4149{
4150 if (type == NULL)
4151 return 0;
d2e4a39e
AS
4152 else
4153 {
4154 switch (TYPE_CODE (type))
4c4b4cd2
PH
4155 {
4156 case TYPE_CODE_INT:
4157 case TYPE_CODE_FLT:
4158 return 1;
4159 case TYPE_CODE_RANGE:
4160 return (type == TYPE_TARGET_TYPE (type)
4161 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4162 default:
4163 return 0;
4164 }
d2e4a39e 4165 }
14f9c5c9
AS
4166}
4167
4c4b4cd2 4168/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
4169
4170static int
d2e4a39e 4171integer_type_p (struct type *type)
14f9c5c9
AS
4172{
4173 if (type == NULL)
4174 return 0;
d2e4a39e
AS
4175 else
4176 {
4177 switch (TYPE_CODE (type))
4c4b4cd2
PH
4178 {
4179 case TYPE_CODE_INT:
4180 return 1;
4181 case TYPE_CODE_RANGE:
4182 return (type == TYPE_TARGET_TYPE (type)
4183 || integer_type_p (TYPE_TARGET_TYPE (type)));
4184 default:
4185 return 0;
4186 }
d2e4a39e 4187 }
14f9c5c9
AS
4188}
4189
4c4b4cd2 4190/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4191
4192static int
d2e4a39e 4193scalar_type_p (struct type *type)
14f9c5c9
AS
4194{
4195 if (type == NULL)
4196 return 0;
d2e4a39e
AS
4197 else
4198 {
4199 switch (TYPE_CODE (type))
4c4b4cd2
PH
4200 {
4201 case TYPE_CODE_INT:
4202 case TYPE_CODE_RANGE:
4203 case TYPE_CODE_ENUM:
4204 case TYPE_CODE_FLT:
4205 return 1;
4206 default:
4207 return 0;
4208 }
d2e4a39e 4209 }
14f9c5c9
AS
4210}
4211
4c4b4cd2 4212/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4213
4214static int
d2e4a39e 4215discrete_type_p (struct type *type)
14f9c5c9
AS
4216{
4217 if (type == NULL)
4218 return 0;
d2e4a39e
AS
4219 else
4220 {
4221 switch (TYPE_CODE (type))
4c4b4cd2
PH
4222 {
4223 case TYPE_CODE_INT:
4224 case TYPE_CODE_RANGE:
4225 case TYPE_CODE_ENUM:
872f0337 4226 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4227 return 1;
4228 default:
4229 return 0;
4230 }
d2e4a39e 4231 }
14f9c5c9
AS
4232}
4233
4c4b4cd2
PH
4234/* Returns non-zero if OP with operands in the vector ARGS could be
4235 a user-defined function. Errs on the side of pre-defined operators
4236 (i.e., result 0). */
14f9c5c9
AS
4237
4238static int
d2e4a39e 4239possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4240{
76a01679 4241 struct type *type0 =
df407dfe 4242 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4243 struct type *type1 =
df407dfe 4244 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4245
4c4b4cd2
PH
4246 if (type0 == NULL)
4247 return 0;
4248
14f9c5c9
AS
4249 switch (op)
4250 {
4251 default:
4252 return 0;
4253
4254 case BINOP_ADD:
4255 case BINOP_SUB:
4256 case BINOP_MUL:
4257 case BINOP_DIV:
d2e4a39e 4258 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4259
4260 case BINOP_REM:
4261 case BINOP_MOD:
4262 case BINOP_BITWISE_AND:
4263 case BINOP_BITWISE_IOR:
4264 case BINOP_BITWISE_XOR:
d2e4a39e 4265 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4266
4267 case BINOP_EQUAL:
4268 case BINOP_NOTEQUAL:
4269 case BINOP_LESS:
4270 case BINOP_GTR:
4271 case BINOP_LEQ:
4272 case BINOP_GEQ:
d2e4a39e 4273 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4274
4275 case BINOP_CONCAT:
ee90b9ab 4276 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4277
4278 case BINOP_EXP:
d2e4a39e 4279 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4280
4281 case UNOP_NEG:
4282 case UNOP_PLUS:
4283 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4284 case UNOP_ABS:
4285 return (!numeric_type_p (type0));
14f9c5c9
AS
4286
4287 }
4288}
4289\f
4c4b4cd2 4290 /* Renaming */
14f9c5c9 4291
aeb5907d
JB
4292/* NOTES:
4293
4294 1. In the following, we assume that a renaming type's name may
4295 have an ___XD suffix. It would be nice if this went away at some
4296 point.
4297 2. We handle both the (old) purely type-based representation of
4298 renamings and the (new) variable-based encoding. At some point,
4299 it is devoutly to be hoped that the former goes away
4300 (FIXME: hilfinger-2007-07-09).
4301 3. Subprogram renamings are not implemented, although the XRS
4302 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4303
4304/* If SYM encodes a renaming,
4305
4306 <renaming> renames <renamed entity>,
4307
4308 sets *LEN to the length of the renamed entity's name,
4309 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4310 the string describing the subcomponent selected from the renamed
0963b4bd 4311 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4312 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4313 are undefined). Otherwise, returns a value indicating the category
4314 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4315 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4316 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4317 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4318 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4319 may be NULL, in which case they are not assigned.
4320
4321 [Currently, however, GCC does not generate subprogram renamings.] */
4322
4323enum ada_renaming_category
4324ada_parse_renaming (struct symbol *sym,
4325 const char **renamed_entity, int *len,
4326 const char **renaming_expr)
4327{
4328 enum ada_renaming_category kind;
4329 const char *info;
4330 const char *suffix;
4331
4332 if (sym == NULL)
4333 return ADA_NOT_RENAMING;
4334 switch (SYMBOL_CLASS (sym))
14f9c5c9 4335 {
aeb5907d
JB
4336 default:
4337 return ADA_NOT_RENAMING;
4338 case LOC_TYPEDEF:
4339 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4340 renamed_entity, len, renaming_expr);
4341 case LOC_LOCAL:
4342 case LOC_STATIC:
4343 case LOC_COMPUTED:
4344 case LOC_OPTIMIZED_OUT:
4345 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4346 if (info == NULL)
4347 return ADA_NOT_RENAMING;
4348 switch (info[5])
4349 {
4350 case '_':
4351 kind = ADA_OBJECT_RENAMING;
4352 info += 6;
4353 break;
4354 case 'E':
4355 kind = ADA_EXCEPTION_RENAMING;
4356 info += 7;
4357 break;
4358 case 'P':
4359 kind = ADA_PACKAGE_RENAMING;
4360 info += 7;
4361 break;
4362 case 'S':
4363 kind = ADA_SUBPROGRAM_RENAMING;
4364 info += 7;
4365 break;
4366 default:
4367 return ADA_NOT_RENAMING;
4368 }
14f9c5c9 4369 }
4c4b4cd2 4370
aeb5907d
JB
4371 if (renamed_entity != NULL)
4372 *renamed_entity = info;
4373 suffix = strstr (info, "___XE");
4374 if (suffix == NULL || suffix == info)
4375 return ADA_NOT_RENAMING;
4376 if (len != NULL)
4377 *len = strlen (info) - strlen (suffix);
4378 suffix += 5;
4379 if (renaming_expr != NULL)
4380 *renaming_expr = suffix;
4381 return kind;
4382}
4383
4384/* Assuming TYPE encodes a renaming according to the old encoding in
4385 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4386 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4387 ADA_NOT_RENAMING otherwise. */
4388static enum ada_renaming_category
4389parse_old_style_renaming (struct type *type,
4390 const char **renamed_entity, int *len,
4391 const char **renaming_expr)
4392{
4393 enum ada_renaming_category kind;
4394 const char *name;
4395 const char *info;
4396 const char *suffix;
14f9c5c9 4397
aeb5907d
JB
4398 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4399 || TYPE_NFIELDS (type) != 1)
4400 return ADA_NOT_RENAMING;
14f9c5c9 4401
aeb5907d
JB
4402 name = type_name_no_tag (type);
4403 if (name == NULL)
4404 return ADA_NOT_RENAMING;
4405
4406 name = strstr (name, "___XR");
4407 if (name == NULL)
4408 return ADA_NOT_RENAMING;
4409 switch (name[5])
4410 {
4411 case '\0':
4412 case '_':
4413 kind = ADA_OBJECT_RENAMING;
4414 break;
4415 case 'E':
4416 kind = ADA_EXCEPTION_RENAMING;
4417 break;
4418 case 'P':
4419 kind = ADA_PACKAGE_RENAMING;
4420 break;
4421 case 'S':
4422 kind = ADA_SUBPROGRAM_RENAMING;
4423 break;
4424 default:
4425 return ADA_NOT_RENAMING;
4426 }
14f9c5c9 4427
aeb5907d
JB
4428 info = TYPE_FIELD_NAME (type, 0);
4429 if (info == NULL)
4430 return ADA_NOT_RENAMING;
4431 if (renamed_entity != NULL)
4432 *renamed_entity = info;
4433 suffix = strstr (info, "___XE");
4434 if (renaming_expr != NULL)
4435 *renaming_expr = suffix + 5;
4436 if (suffix == NULL || suffix == info)
4437 return ADA_NOT_RENAMING;
4438 if (len != NULL)
4439 *len = suffix - info;
4440 return kind;
a5ee536b
JB
4441}
4442
4443/* Compute the value of the given RENAMING_SYM, which is expected to
4444 be a symbol encoding a renaming expression. BLOCK is the block
4445 used to evaluate the renaming. */
52ce6436 4446
a5ee536b
JB
4447static struct value *
4448ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4449 const struct block *block)
a5ee536b 4450{
bbc13ae3 4451 const char *sym_name;
a5ee536b 4452
bbc13ae3 4453 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4d01a485
PA
4454 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4455 return evaluate_expression (expr.get ());
a5ee536b 4456}
14f9c5c9 4457\f
d2e4a39e 4458
4c4b4cd2 4459 /* Evaluation: Function Calls */
14f9c5c9 4460
4c4b4cd2 4461/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4462 lvalues, and otherwise has the side-effect of allocating memory
4463 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4464
d2e4a39e 4465static struct value *
40bc484c 4466ensure_lval (struct value *val)
14f9c5c9 4467{
40bc484c
JB
4468 if (VALUE_LVAL (val) == not_lval
4469 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4470 {
df407dfe 4471 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4472 const CORE_ADDR addr =
4473 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4474
a84a8a0d 4475 VALUE_LVAL (val) = lval_memory;
1a088441 4476 set_value_address (val, addr);
40bc484c 4477 write_memory (addr, value_contents (val), len);
c3e5cd34 4478 }
14f9c5c9
AS
4479
4480 return val;
4481}
4482
4483/* Return the value ACTUAL, converted to be an appropriate value for a
4484 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4485 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4486 values not residing in memory, updating it as needed. */
14f9c5c9 4487
a93c0eb6 4488struct value *
40bc484c 4489ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4490{
df407dfe 4491 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4492 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4493 struct type *formal_target =
4494 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4495 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4496 struct type *actual_target =
4497 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4498 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4499
4c4b4cd2 4500 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4501 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4502 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4503 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4504 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4505 {
a84a8a0d 4506 struct value *result;
5b4ee69b 4507
14f9c5c9 4508 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4509 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4510 result = desc_data (actual);
14f9c5c9 4511 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4512 {
4513 if (VALUE_LVAL (actual) != lval_memory)
4514 {
4515 struct value *val;
5b4ee69b 4516
df407dfe 4517 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4518 val = allocate_value (actual_type);
990a07ab 4519 memcpy ((char *) value_contents_raw (val),
0fd88904 4520 (char *) value_contents (actual),
4c4b4cd2 4521 TYPE_LENGTH (actual_type));
40bc484c 4522 actual = ensure_lval (val);
4c4b4cd2 4523 }
a84a8a0d 4524 result = value_addr (actual);
4c4b4cd2 4525 }
a84a8a0d
JB
4526 else
4527 return actual;
b1af9e97 4528 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4529 }
4530 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4531 return ada_value_ind (actual);
8344af1e
JB
4532 else if (ada_is_aligner_type (formal_type))
4533 {
4534 /* We need to turn this parameter into an aligner type
4535 as well. */
4536 struct value *aligner = allocate_value (formal_type);
4537 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4538
4539 value_assign_to_component (aligner, component, actual);
4540 return aligner;
4541 }
14f9c5c9
AS
4542
4543 return actual;
4544}
4545
438c98a1
JB
4546/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4547 type TYPE. This is usually an inefficient no-op except on some targets
4548 (such as AVR) where the representation of a pointer and an address
4549 differs. */
4550
4551static CORE_ADDR
4552value_pointer (struct value *value, struct type *type)
4553{
4554 struct gdbarch *gdbarch = get_type_arch (type);
4555 unsigned len = TYPE_LENGTH (type);
224c3ddb 4556 gdb_byte *buf = (gdb_byte *) alloca (len);
438c98a1
JB
4557 CORE_ADDR addr;
4558
4559 addr = value_address (value);
4560 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4561 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4562 return addr;
4563}
4564
14f9c5c9 4565
4c4b4cd2
PH
4566/* Push a descriptor of type TYPE for array value ARR on the stack at
4567 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4568 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4569 to-descriptor type rather than a descriptor type), a struct value *
4570 representing a pointer to this descriptor. */
14f9c5c9 4571
d2e4a39e 4572static struct value *
40bc484c 4573make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4574{
d2e4a39e
AS
4575 struct type *bounds_type = desc_bounds_type (type);
4576 struct type *desc_type = desc_base_type (type);
4577 struct value *descriptor = allocate_value (desc_type);
4578 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4579 int i;
d2e4a39e 4580
0963b4bd
MS
4581 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4582 i > 0; i -= 1)
14f9c5c9 4583 {
19f220c3
JK
4584 modify_field (value_type (bounds), value_contents_writeable (bounds),
4585 ada_array_bound (arr, i, 0),
4586 desc_bound_bitpos (bounds_type, i, 0),
4587 desc_bound_bitsize (bounds_type, i, 0));
4588 modify_field (value_type (bounds), value_contents_writeable (bounds),
4589 ada_array_bound (arr, i, 1),
4590 desc_bound_bitpos (bounds_type, i, 1),
4591 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4592 }
d2e4a39e 4593
40bc484c 4594 bounds = ensure_lval (bounds);
d2e4a39e 4595
19f220c3
JK
4596 modify_field (value_type (descriptor),
4597 value_contents_writeable (descriptor),
4598 value_pointer (ensure_lval (arr),
4599 TYPE_FIELD_TYPE (desc_type, 0)),
4600 fat_pntr_data_bitpos (desc_type),
4601 fat_pntr_data_bitsize (desc_type));
4602
4603 modify_field (value_type (descriptor),
4604 value_contents_writeable (descriptor),
4605 value_pointer (bounds,
4606 TYPE_FIELD_TYPE (desc_type, 1)),
4607 fat_pntr_bounds_bitpos (desc_type),
4608 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4609
40bc484c 4610 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4611
4612 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4613 return value_addr (descriptor);
4614 else
4615 return descriptor;
4616}
14f9c5c9 4617\f
3d9434b5
JB
4618 /* Symbol Cache Module */
4619
3d9434b5 4620/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4621 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4622 on the type of entity being printed, the cache can make it as much
4623 as an order of magnitude faster than without it.
4624
4625 The descriptive type DWARF extension has significantly reduced
4626 the need for this cache, at least when DWARF is being used. However,
4627 even in this case, some expensive name-based symbol searches are still
4628 sometimes necessary - to find an XVZ variable, mostly. */
4629
ee01b665 4630/* Initialize the contents of SYM_CACHE. */
3d9434b5 4631
ee01b665
JB
4632static void
4633ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4634{
4635 obstack_init (&sym_cache->cache_space);
4636 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4637}
3d9434b5 4638
ee01b665
JB
4639/* Free the memory used by SYM_CACHE. */
4640
4641static void
4642ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4643{
ee01b665
JB
4644 obstack_free (&sym_cache->cache_space, NULL);
4645 xfree (sym_cache);
4646}
3d9434b5 4647
ee01b665
JB
4648/* Return the symbol cache associated to the given program space PSPACE.
4649 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4650
ee01b665
JB
4651static struct ada_symbol_cache *
4652ada_get_symbol_cache (struct program_space *pspace)
4653{
4654 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4655
66c168ae 4656 if (pspace_data->sym_cache == NULL)
ee01b665 4657 {
66c168ae
JB
4658 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4659 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4660 }
4661
66c168ae 4662 return pspace_data->sym_cache;
ee01b665 4663}
3d9434b5
JB
4664
4665/* Clear all entries from the symbol cache. */
4666
4667static void
4668ada_clear_symbol_cache (void)
4669{
ee01b665
JB
4670 struct ada_symbol_cache *sym_cache
4671 = ada_get_symbol_cache (current_program_space);
4672
4673 obstack_free (&sym_cache->cache_space, NULL);
4674 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4675}
4676
fe978cb0 4677/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4678 Return it if found, or NULL otherwise. */
4679
4680static struct cache_entry **
fe978cb0 4681find_entry (const char *name, domain_enum domain)
3d9434b5 4682{
ee01b665
JB
4683 struct ada_symbol_cache *sym_cache
4684 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4685 int h = msymbol_hash (name) % HASH_SIZE;
4686 struct cache_entry **e;
4687
ee01b665 4688 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4689 {
fe978cb0 4690 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4691 return e;
4692 }
4693 return NULL;
4694}
4695
fe978cb0 4696/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4697 Return 1 if found, 0 otherwise.
4698
4699 If an entry was found and SYM is not NULL, set *SYM to the entry's
4700 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4701
96d887e8 4702static int
fe978cb0 4703lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4704 struct symbol **sym, const struct block **block)
96d887e8 4705{
fe978cb0 4706 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4707
4708 if (e == NULL)
4709 return 0;
4710 if (sym != NULL)
4711 *sym = (*e)->sym;
4712 if (block != NULL)
4713 *block = (*e)->block;
4714 return 1;
96d887e8
PH
4715}
4716
3d9434b5 4717/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4718 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4719
96d887e8 4720static void
fe978cb0 4721cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4722 const struct block *block)
96d887e8 4723{
ee01b665
JB
4724 struct ada_symbol_cache *sym_cache
4725 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4726 int h;
4727 char *copy;
4728 struct cache_entry *e;
4729
1994afbf
DE
4730 /* Symbols for builtin types don't have a block.
4731 For now don't cache such symbols. */
4732 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4733 return;
4734
3d9434b5
JB
4735 /* If the symbol is a local symbol, then do not cache it, as a search
4736 for that symbol depends on the context. To determine whether
4737 the symbol is local or not, we check the block where we found it
4738 against the global and static blocks of its associated symtab. */
4739 if (sym
08be3fe3 4740 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4741 GLOBAL_BLOCK) != block
08be3fe3 4742 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4743 STATIC_BLOCK) != block)
3d9434b5
JB
4744 return;
4745
4746 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4747 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4748 sizeof (*e));
4749 e->next = sym_cache->root[h];
4750 sym_cache->root[h] = e;
224c3ddb
SM
4751 e->name = copy
4752 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4753 strcpy (copy, name);
4754 e->sym = sym;
fe978cb0 4755 e->domain = domain;
3d9434b5 4756 e->block = block;
96d887e8 4757}
4c4b4cd2
PH
4758\f
4759 /* Symbol Lookup */
4760
c0431670
JB
4761/* Return nonzero if wild matching should be used when searching for
4762 all symbols matching LOOKUP_NAME.
4763
4764 LOOKUP_NAME is expected to be a symbol name after transformation
4765 for Ada lookups (see ada_name_for_lookup). */
4766
4767static int
4768should_use_wild_match (const char *lookup_name)
4769{
4770 return (strstr (lookup_name, "__") == NULL);
4771}
4772
4c4b4cd2
PH
4773/* Return the result of a standard (literal, C-like) lookup of NAME in
4774 given DOMAIN, visible from lexical block BLOCK. */
4775
4776static struct symbol *
4777standard_lookup (const char *name, const struct block *block,
4778 domain_enum domain)
4779{
acbd605d 4780 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4781 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4782
d12307c1
PMR
4783 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4784 return sym.symbol;
2570f2b7 4785 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4786 cache_symbol (name, domain, sym.symbol, sym.block);
4787 return sym.symbol;
4c4b4cd2
PH
4788}
4789
4790
4791/* Non-zero iff there is at least one non-function/non-enumeral symbol
4792 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4793 since they contend in overloading in the same way. */
4794static int
d12307c1 4795is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4796{
4797 int i;
4798
4799 for (i = 0; i < n; i += 1)
d12307c1
PMR
4800 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4801 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4802 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4803 return 1;
4804
4805 return 0;
4806}
4807
4808/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4809 struct types. Otherwise, they may not. */
14f9c5c9
AS
4810
4811static int
d2e4a39e 4812equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4813{
d2e4a39e 4814 if (type0 == type1)
14f9c5c9 4815 return 1;
d2e4a39e 4816 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4817 || TYPE_CODE (type0) != TYPE_CODE (type1))
4818 return 0;
d2e4a39e 4819 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4820 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4821 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4822 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4823 return 1;
d2e4a39e 4824
14f9c5c9
AS
4825 return 0;
4826}
4827
4828/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4829 no more defined than that of SYM1. */
14f9c5c9
AS
4830
4831static int
d2e4a39e 4832lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4833{
4834 if (sym0 == sym1)
4835 return 1;
176620f1 4836 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4837 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4838 return 0;
4839
d2e4a39e 4840 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4841 {
4842 case LOC_UNDEF:
4843 return 1;
4844 case LOC_TYPEDEF:
4845 {
4c4b4cd2
PH
4846 struct type *type0 = SYMBOL_TYPE (sym0);
4847 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4848 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4849 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4850 int len0 = strlen (name0);
5b4ee69b 4851
4c4b4cd2
PH
4852 return
4853 TYPE_CODE (type0) == TYPE_CODE (type1)
4854 && (equiv_types (type0, type1)
4855 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4856 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4857 }
4858 case LOC_CONST:
4859 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4860 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4861 default:
4862 return 0;
14f9c5c9
AS
4863 }
4864}
4865
d12307c1 4866/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4867 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4868
4869static void
76a01679
JB
4870add_defn_to_vec (struct obstack *obstackp,
4871 struct symbol *sym,
f0c5f9b2 4872 const struct block *block)
14f9c5c9
AS
4873{
4874 int i;
d12307c1 4875 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4876
529cad9c
PH
4877 /* Do not try to complete stub types, as the debugger is probably
4878 already scanning all symbols matching a certain name at the
4879 time when this function is called. Trying to replace the stub
4880 type by its associated full type will cause us to restart a scan
4881 which may lead to an infinite recursion. Instead, the client
4882 collecting the matching symbols will end up collecting several
4883 matches, with at least one of them complete. It can then filter
4884 out the stub ones if needed. */
4885
4c4b4cd2
PH
4886 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4887 {
d12307c1 4888 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4889 return;
d12307c1 4890 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4891 {
d12307c1 4892 prevDefns[i].symbol = sym;
4c4b4cd2 4893 prevDefns[i].block = block;
4c4b4cd2 4894 return;
76a01679 4895 }
4c4b4cd2
PH
4896 }
4897
4898 {
d12307c1 4899 struct block_symbol info;
4c4b4cd2 4900
d12307c1 4901 info.symbol = sym;
4c4b4cd2 4902 info.block = block;
d12307c1 4903 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4904 }
4905}
4906
d12307c1
PMR
4907/* Number of block_symbol structures currently collected in current vector in
4908 OBSTACKP. */
4c4b4cd2 4909
76a01679
JB
4910static int
4911num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4912{
d12307c1 4913 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4914}
4915
d12307c1
PMR
4916/* Vector of block_symbol structures currently collected in current vector in
4917 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4918
d12307c1 4919static struct block_symbol *
4c4b4cd2
PH
4920defns_collected (struct obstack *obstackp, int finish)
4921{
4922 if (finish)
224c3ddb 4923 return (struct block_symbol *) obstack_finish (obstackp);
4c4b4cd2 4924 else
d12307c1 4925 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4926}
4927
7c7b6655
TT
4928/* Return a bound minimal symbol matching NAME according to Ada
4929 decoding rules. Returns an invalid symbol if there is no such
4930 minimal symbol. Names prefixed with "standard__" are handled
4931 specially: "standard__" is first stripped off, and only static and
4932 global symbols are searched. */
4c4b4cd2 4933
7c7b6655 4934struct bound_minimal_symbol
96d887e8 4935ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4936{
7c7b6655 4937 struct bound_minimal_symbol result;
4c4b4cd2 4938 struct objfile *objfile;
96d887e8 4939 struct minimal_symbol *msymbol;
dc4024cd 4940 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4941
7c7b6655
TT
4942 memset (&result, 0, sizeof (result));
4943
c0431670
JB
4944 /* Special case: If the user specifies a symbol name inside package
4945 Standard, do a non-wild matching of the symbol name without
4946 the "standard__" prefix. This was primarily introduced in order
4947 to allow the user to specifically access the standard exceptions
4948 using, for instance, Standard.Constraint_Error when Constraint_Error
4949 is ambiguous (due to the user defining its own Constraint_Error
4950 entity inside its program). */
61012eef 4951 if (startswith (name, "standard__"))
c0431670 4952 name += sizeof ("standard__") - 1;
4c4b4cd2 4953
96d887e8
PH
4954 ALL_MSYMBOLS (objfile, msymbol)
4955 {
efd66ac6 4956 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4957 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4958 {
4959 result.minsym = msymbol;
4960 result.objfile = objfile;
4961 break;
4962 }
96d887e8 4963 }
4c4b4cd2 4964
7c7b6655 4965 return result;
96d887e8 4966}
4c4b4cd2 4967
96d887e8
PH
4968/* For all subprograms that statically enclose the subprogram of the
4969 selected frame, add symbols matching identifier NAME in DOMAIN
4970 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4971 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4972 with a wildcard prefix. */
4c4b4cd2 4973
96d887e8
PH
4974static void
4975add_symbols_from_enclosing_procs (struct obstack *obstackp,
fe978cb0 4976 const char *name, domain_enum domain,
48b78332 4977 int wild_match_p)
96d887e8 4978{
96d887e8 4979}
14f9c5c9 4980
96d887e8
PH
4981/* True if TYPE is definitely an artificial type supplied to a symbol
4982 for which no debugging information was given in the symbol file. */
14f9c5c9 4983
96d887e8
PH
4984static int
4985is_nondebugging_type (struct type *type)
4986{
0d5cff50 4987 const char *name = ada_type_name (type);
5b4ee69b 4988
96d887e8
PH
4989 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4990}
4c4b4cd2 4991
8f17729f
JB
4992/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4993 that are deemed "identical" for practical purposes.
4994
4995 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4996 types and that their number of enumerals is identical (in other
4997 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4998
4999static int
5000ada_identical_enum_types_p (struct type *type1, struct type *type2)
5001{
5002 int i;
5003
5004 /* The heuristic we use here is fairly conservative. We consider
5005 that 2 enumerate types are identical if they have the same
5006 number of enumerals and that all enumerals have the same
5007 underlying value and name. */
5008
5009 /* All enums in the type should have an identical underlying value. */
5010 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 5011 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
5012 return 0;
5013
5014 /* All enumerals should also have the same name (modulo any numerical
5015 suffix). */
5016 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5017 {
0d5cff50
DE
5018 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5019 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
5020 int len_1 = strlen (name_1);
5021 int len_2 = strlen (name_2);
5022
5023 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5024 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5025 if (len_1 != len_2
5026 || strncmp (TYPE_FIELD_NAME (type1, i),
5027 TYPE_FIELD_NAME (type2, i),
5028 len_1) != 0)
5029 return 0;
5030 }
5031
5032 return 1;
5033}
5034
5035/* Return nonzero if all the symbols in SYMS are all enumeral symbols
5036 that are deemed "identical" for practical purposes. Sometimes,
5037 enumerals are not strictly identical, but their types are so similar
5038 that they can be considered identical.
5039
5040 For instance, consider the following code:
5041
5042 type Color is (Black, Red, Green, Blue, White);
5043 type RGB_Color is new Color range Red .. Blue;
5044
5045 Type RGB_Color is a subrange of an implicit type which is a copy
5046 of type Color. If we call that implicit type RGB_ColorB ("B" is
5047 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5048 As a result, when an expression references any of the enumeral
5049 by name (Eg. "print green"), the expression is technically
5050 ambiguous and the user should be asked to disambiguate. But
5051 doing so would only hinder the user, since it wouldn't matter
5052 what choice he makes, the outcome would always be the same.
5053 So, for practical purposes, we consider them as the same. */
5054
5055static int
d12307c1 5056symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
8f17729f
JB
5057{
5058 int i;
5059
5060 /* Before performing a thorough comparison check of each type,
5061 we perform a series of inexpensive checks. We expect that these
5062 checks will quickly fail in the vast majority of cases, and thus
5063 help prevent the unnecessary use of a more expensive comparison.
5064 Said comparison also expects us to make some of these checks
5065 (see ada_identical_enum_types_p). */
5066
5067 /* Quick check: All symbols should have an enum type. */
5068 for (i = 0; i < nsyms; i++)
d12307c1 5069 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
5070 return 0;
5071
5072 /* Quick check: They should all have the same value. */
5073 for (i = 1; i < nsyms; i++)
d12307c1 5074 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
5075 return 0;
5076
5077 /* Quick check: They should all have the same number of enumerals. */
5078 for (i = 1; i < nsyms; i++)
d12307c1
PMR
5079 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5080 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5081 return 0;
5082
5083 /* All the sanity checks passed, so we might have a set of
5084 identical enumeration types. Perform a more complete
5085 comparison of the type of each symbol. */
5086 for (i = 1; i < nsyms; i++)
d12307c1
PMR
5087 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5088 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
5089 return 0;
5090
5091 return 1;
5092}
5093
96d887e8
PH
5094/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5095 duplicate other symbols in the list (The only case I know of where
5096 this happens is when object files containing stabs-in-ecoff are
5097 linked with files containing ordinary ecoff debugging symbols (or no
5098 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5099 Returns the number of items in the modified list. */
4c4b4cd2 5100
96d887e8 5101static int
d12307c1 5102remove_extra_symbols (struct block_symbol *syms, int nsyms)
96d887e8
PH
5103{
5104 int i, j;
4c4b4cd2 5105
8f17729f
JB
5106 /* We should never be called with less than 2 symbols, as there
5107 cannot be any extra symbol in that case. But it's easy to
5108 handle, since we have nothing to do in that case. */
5109 if (nsyms < 2)
5110 return nsyms;
5111
96d887e8
PH
5112 i = 0;
5113 while (i < nsyms)
5114 {
a35ddb44 5115 int remove_p = 0;
339c13b6
JB
5116
5117 /* If two symbols have the same name and one of them is a stub type,
5118 the get rid of the stub. */
5119
d12307c1
PMR
5120 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5121 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
339c13b6
JB
5122 {
5123 for (j = 0; j < nsyms; j++)
5124 {
5125 if (j != i
d12307c1
PMR
5126 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5127 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5128 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5129 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
a35ddb44 5130 remove_p = 1;
339c13b6
JB
5131 }
5132 }
5133
5134 /* Two symbols with the same name, same class and same address
5135 should be identical. */
5136
d12307c1
PMR
5137 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5138 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5139 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
96d887e8
PH
5140 {
5141 for (j = 0; j < nsyms; j += 1)
5142 {
5143 if (i != j
d12307c1
PMR
5144 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5145 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5146 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5147 && SYMBOL_CLASS (syms[i].symbol)
5148 == SYMBOL_CLASS (syms[j].symbol)
5149 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5150 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
a35ddb44 5151 remove_p = 1;
4c4b4cd2 5152 }
4c4b4cd2 5153 }
339c13b6 5154
a35ddb44 5155 if (remove_p)
339c13b6
JB
5156 {
5157 for (j = i + 1; j < nsyms; j += 1)
5158 syms[j - 1] = syms[j];
5159 nsyms -= 1;
5160 }
5161
96d887e8 5162 i += 1;
14f9c5c9 5163 }
8f17729f
JB
5164
5165 /* If all the remaining symbols are identical enumerals, then
5166 just keep the first one and discard the rest.
5167
5168 Unlike what we did previously, we do not discard any entry
5169 unless they are ALL identical. This is because the symbol
5170 comparison is not a strict comparison, but rather a practical
5171 comparison. If all symbols are considered identical, then
5172 we can just go ahead and use the first one and discard the rest.
5173 But if we cannot reduce the list to a single element, we have
5174 to ask the user to disambiguate anyways. And if we have to
5175 present a multiple-choice menu, it's less confusing if the list
5176 isn't missing some choices that were identical and yet distinct. */
5177 if (symbols_are_identical_enums (syms, nsyms))
5178 nsyms = 1;
5179
96d887e8 5180 return nsyms;
14f9c5c9
AS
5181}
5182
96d887e8
PH
5183/* Given a type that corresponds to a renaming entity, use the type name
5184 to extract the scope (package name or function name, fully qualified,
5185 and following the GNAT encoding convention) where this renaming has been
5186 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 5187
96d887e8
PH
5188static char *
5189xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5190{
96d887e8 5191 /* The renaming types adhere to the following convention:
0963b4bd 5192 <scope>__<rename>___<XR extension>.
96d887e8
PH
5193 So, to extract the scope, we search for the "___XR" extension,
5194 and then backtrack until we find the first "__". */
76a01679 5195
96d887e8 5196 const char *name = type_name_no_tag (renaming_type);
108d56a4
SM
5197 const char *suffix = strstr (name, "___XR");
5198 const char *last;
96d887e8
PH
5199 int scope_len;
5200 char *scope;
14f9c5c9 5201
96d887e8
PH
5202 /* Now, backtrack a bit until we find the first "__". Start looking
5203 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5204
96d887e8
PH
5205 for (last = suffix - 3; last > name; last--)
5206 if (last[0] == '_' && last[1] == '_')
5207 break;
76a01679 5208
96d887e8 5209 /* Make a copy of scope and return it. */
14f9c5c9 5210
96d887e8
PH
5211 scope_len = last - name;
5212 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 5213
96d887e8
PH
5214 strncpy (scope, name, scope_len);
5215 scope[scope_len] = '\0';
4c4b4cd2 5216
96d887e8 5217 return scope;
4c4b4cd2
PH
5218}
5219
96d887e8 5220/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5221
96d887e8
PH
5222static int
5223is_package_name (const char *name)
4c4b4cd2 5224{
96d887e8
PH
5225 /* Here, We take advantage of the fact that no symbols are generated
5226 for packages, while symbols are generated for each function.
5227 So the condition for NAME represent a package becomes equivalent
5228 to NAME not existing in our list of symbols. There is only one
5229 small complication with library-level functions (see below). */
4c4b4cd2 5230
96d887e8 5231 char *fun_name;
76a01679 5232
96d887e8
PH
5233 /* If it is a function that has not been defined at library level,
5234 then we should be able to look it up in the symbols. */
5235 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5236 return 0;
14f9c5c9 5237
96d887e8
PH
5238 /* Library-level function names start with "_ada_". See if function
5239 "_ada_" followed by NAME can be found. */
14f9c5c9 5240
96d887e8 5241 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5242 functions names cannot contain "__" in them. */
96d887e8
PH
5243 if (strstr (name, "__") != NULL)
5244 return 0;
4c4b4cd2 5245
b435e160 5246 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 5247
96d887e8
PH
5248 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5249}
14f9c5c9 5250
96d887e8 5251/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5252 not visible from FUNCTION_NAME. */
14f9c5c9 5253
96d887e8 5254static int
0d5cff50 5255old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5256{
aeb5907d 5257 char *scope;
1509e573 5258 struct cleanup *old_chain;
aeb5907d
JB
5259
5260 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5261 return 0;
5262
5263 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 5264 old_chain = make_cleanup (xfree, scope);
14f9c5c9 5265
96d887e8
PH
5266 /* If the rename has been defined in a package, then it is visible. */
5267 if (is_package_name (scope))
1509e573
JB
5268 {
5269 do_cleanups (old_chain);
5270 return 0;
5271 }
14f9c5c9 5272
96d887e8
PH
5273 /* Check that the rename is in the current function scope by checking
5274 that its name starts with SCOPE. */
76a01679 5275
96d887e8
PH
5276 /* If the function name starts with "_ada_", it means that it is
5277 a library-level function. Strip this prefix before doing the
5278 comparison, as the encoding for the renaming does not contain
5279 this prefix. */
61012eef 5280 if (startswith (function_name, "_ada_"))
96d887e8 5281 function_name += 5;
f26caa11 5282
1509e573 5283 {
61012eef 5284 int is_invisible = !startswith (function_name, scope);
1509e573
JB
5285
5286 do_cleanups (old_chain);
5287 return is_invisible;
5288 }
f26caa11
PH
5289}
5290
aeb5907d
JB
5291/* Remove entries from SYMS that corresponds to a renaming entity that
5292 is not visible from the function associated with CURRENT_BLOCK or
5293 that is superfluous due to the presence of more specific renaming
5294 information. Places surviving symbols in the initial entries of
5295 SYMS and returns the number of surviving symbols.
96d887e8
PH
5296
5297 Rationale:
aeb5907d
JB
5298 First, in cases where an object renaming is implemented as a
5299 reference variable, GNAT may produce both the actual reference
5300 variable and the renaming encoding. In this case, we discard the
5301 latter.
5302
5303 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5304 entity. Unfortunately, STABS currently does not support the definition
5305 of types that are local to a given lexical block, so all renamings types
5306 are emitted at library level. As a consequence, if an application
5307 contains two renaming entities using the same name, and a user tries to
5308 print the value of one of these entities, the result of the ada symbol
5309 lookup will also contain the wrong renaming type.
f26caa11 5310
96d887e8
PH
5311 This function partially covers for this limitation by attempting to
5312 remove from the SYMS list renaming symbols that should be visible
5313 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5314 method with the current information available. The implementation
5315 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5316
5317 - When the user tries to print a rename in a function while there
5318 is another rename entity defined in a package: Normally, the
5319 rename in the function has precedence over the rename in the
5320 package, so the latter should be removed from the list. This is
5321 currently not the case.
5322
5323 - This function will incorrectly remove valid renames if
5324 the CURRENT_BLOCK corresponds to a function which symbol name
5325 has been changed by an "Export" pragma. As a consequence,
5326 the user will be unable to print such rename entities. */
4c4b4cd2 5327
14f9c5c9 5328static int
d12307c1 5329remove_irrelevant_renamings (struct block_symbol *syms,
aeb5907d 5330 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5331{
5332 struct symbol *current_function;
0d5cff50 5333 const char *current_function_name;
4c4b4cd2 5334 int i;
aeb5907d
JB
5335 int is_new_style_renaming;
5336
5337 /* If there is both a renaming foo___XR... encoded as a variable and
5338 a simple variable foo in the same block, discard the latter.
0963b4bd 5339 First, zero out such symbols, then compress. */
aeb5907d
JB
5340 is_new_style_renaming = 0;
5341 for (i = 0; i < nsyms; i += 1)
5342 {
d12307c1 5343 struct symbol *sym = syms[i].symbol;
270140bd 5344 const struct block *block = syms[i].block;
aeb5907d
JB
5345 const char *name;
5346 const char *suffix;
5347
5348 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5349 continue;
5350 name = SYMBOL_LINKAGE_NAME (sym);
5351 suffix = strstr (name, "___XR");
5352
5353 if (suffix != NULL)
5354 {
5355 int name_len = suffix - name;
5356 int j;
5b4ee69b 5357
aeb5907d
JB
5358 is_new_style_renaming = 1;
5359 for (j = 0; j < nsyms; j += 1)
d12307c1
PMR
5360 if (i != j && syms[j].symbol != NULL
5361 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
aeb5907d
JB
5362 name_len) == 0
5363 && block == syms[j].block)
d12307c1 5364 syms[j].symbol = NULL;
aeb5907d
JB
5365 }
5366 }
5367 if (is_new_style_renaming)
5368 {
5369 int j, k;
5370
5371 for (j = k = 0; j < nsyms; j += 1)
d12307c1 5372 if (syms[j].symbol != NULL)
aeb5907d
JB
5373 {
5374 syms[k] = syms[j];
5375 k += 1;
5376 }
5377 return k;
5378 }
4c4b4cd2
PH
5379
5380 /* Extract the function name associated to CURRENT_BLOCK.
5381 Abort if unable to do so. */
76a01679 5382
4c4b4cd2
PH
5383 if (current_block == NULL)
5384 return nsyms;
76a01679 5385
7f0df278 5386 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5387 if (current_function == NULL)
5388 return nsyms;
5389
5390 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5391 if (current_function_name == NULL)
5392 return nsyms;
5393
5394 /* Check each of the symbols, and remove it from the list if it is
5395 a type corresponding to a renaming that is out of the scope of
5396 the current block. */
5397
5398 i = 0;
5399 while (i < nsyms)
5400 {
d12307c1 5401 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
aeb5907d 5402 == ADA_OBJECT_RENAMING
d12307c1 5403 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
4c4b4cd2
PH
5404 {
5405 int j;
5b4ee69b 5406
aeb5907d 5407 for (j = i + 1; j < nsyms; j += 1)
76a01679 5408 syms[j - 1] = syms[j];
4c4b4cd2
PH
5409 nsyms -= 1;
5410 }
5411 else
5412 i += 1;
5413 }
5414
5415 return nsyms;
5416}
5417
339c13b6
JB
5418/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5419 whose name and domain match NAME and DOMAIN respectively.
5420 If no match was found, then extend the search to "enclosing"
5421 routines (in other words, if we're inside a nested function,
5422 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5423 If WILD_MATCH_P is nonzero, perform the naming matching in
5424 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5425
5426 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5427
5428static void
5429ada_add_local_symbols (struct obstack *obstackp, const char *name,
f0c5f9b2 5430 const struct block *block, domain_enum domain,
d0a8ab18 5431 int wild_match_p)
339c13b6
JB
5432{
5433 int block_depth = 0;
5434
5435 while (block != NULL)
5436 {
5437 block_depth += 1;
d0a8ab18
JB
5438 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5439 wild_match_p);
339c13b6
JB
5440
5441 /* If we found a non-function match, assume that's the one. */
5442 if (is_nonfunction (defns_collected (obstackp, 0),
5443 num_defns_collected (obstackp)))
5444 return;
5445
5446 block = BLOCK_SUPERBLOCK (block);
5447 }
5448
5449 /* If no luck so far, try to find NAME as a local symbol in some lexically
5450 enclosing subprogram. */
5451 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 5452 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
5453}
5454
ccefe4c4 5455/* An object of this type is used as the user_data argument when
40658b94 5456 calling the map_matching_symbols method. */
ccefe4c4 5457
40658b94 5458struct match_data
ccefe4c4 5459{
40658b94 5460 struct objfile *objfile;
ccefe4c4 5461 struct obstack *obstackp;
40658b94
PH
5462 struct symbol *arg_sym;
5463 int found_sym;
ccefe4c4
TT
5464};
5465
22cee43f 5466/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
40658b94
PH
5467 to a list of symbols. DATA0 is a pointer to a struct match_data *
5468 containing the obstack that collects the symbol list, the file that SYM
5469 must come from, a flag indicating whether a non-argument symbol has
5470 been found in the current block, and the last argument symbol
5471 passed in SYM within the current block (if any). When SYM is null,
5472 marking the end of a block, the argument symbol is added if no
5473 other has been found. */
ccefe4c4 5474
40658b94
PH
5475static int
5476aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5477{
40658b94
PH
5478 struct match_data *data = (struct match_data *) data0;
5479
5480 if (sym == NULL)
5481 {
5482 if (!data->found_sym && data->arg_sym != NULL)
5483 add_defn_to_vec (data->obstackp,
5484 fixup_symbol_section (data->arg_sym, data->objfile),
5485 block);
5486 data->found_sym = 0;
5487 data->arg_sym = NULL;
5488 }
5489 else
5490 {
5491 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5492 return 0;
5493 else if (SYMBOL_IS_ARGUMENT (sym))
5494 data->arg_sym = sym;
5495 else
5496 {
5497 data->found_sym = 1;
5498 add_defn_to_vec (data->obstackp,
5499 fixup_symbol_section (sym, data->objfile),
5500 block);
5501 }
5502 }
5503 return 0;
5504}
5505
22cee43f
PMR
5506/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are targetted
5507 by renamings matching NAME in BLOCK. Add these symbols to OBSTACKP. If
5508 WILD_MATCH_P is nonzero, perform the naming matching in "wild" mode (see
5509 function "wild_match" for more information). Return whether we found such
5510 symbols. */
5511
5512static int
5513ada_add_block_renamings (struct obstack *obstackp,
5514 const struct block *block,
5515 const char *name,
5516 domain_enum domain,
5517 int wild_match_p)
5518{
5519 struct using_direct *renaming;
5520 int defns_mark = num_defns_collected (obstackp);
5521
5522 for (renaming = block_using (block);
5523 renaming != NULL;
5524 renaming = renaming->next)
5525 {
5526 const char *r_name;
5527 int name_match;
5528
5529 /* Avoid infinite recursions: skip this renaming if we are actually
5530 already traversing it.
5531
5532 Currently, symbol lookup in Ada don't use the namespace machinery from
5533 C++/Fortran support: skip namespace imports that use them. */
5534 if (renaming->searched
5535 || (renaming->import_src != NULL
5536 && renaming->import_src[0] != '\0')
5537 || (renaming->import_dest != NULL
5538 && renaming->import_dest[0] != '\0'))
5539 continue;
5540 renaming->searched = 1;
5541
5542 /* TODO: here, we perform another name-based symbol lookup, which can
5543 pull its own multiple overloads. In theory, we should be able to do
5544 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5545 not a simple name. But in order to do this, we would need to enhance
5546 the DWARF reader to associate a symbol to this renaming, instead of a
5547 name. So, for now, we do something simpler: re-use the C++/Fortran
5548 namespace machinery. */
5549 r_name = (renaming->alias != NULL
5550 ? renaming->alias
5551 : renaming->declaration);
5552 name_match
5553 = wild_match_p ? wild_match (r_name, name) : strcmp (r_name, name);
5554 if (name_match == 0)
5555 ada_add_all_symbols (obstackp, block, renaming->declaration, domain,
5556 1, NULL);
5557 renaming->searched = 0;
5558 }
5559 return num_defns_collected (obstackp) != defns_mark;
5560}
5561
db230ce3
JB
5562/* Implements compare_names, but only applying the comparision using
5563 the given CASING. */
5b4ee69b 5564
40658b94 5565static int
db230ce3
JB
5566compare_names_with_case (const char *string1, const char *string2,
5567 enum case_sensitivity casing)
40658b94
PH
5568{
5569 while (*string1 != '\0' && *string2 != '\0')
5570 {
db230ce3
JB
5571 char c1, c2;
5572
40658b94
PH
5573 if (isspace (*string1) || isspace (*string2))
5574 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5575
5576 if (casing == case_sensitive_off)
5577 {
5578 c1 = tolower (*string1);
5579 c2 = tolower (*string2);
5580 }
5581 else
5582 {
5583 c1 = *string1;
5584 c2 = *string2;
5585 }
5586 if (c1 != c2)
40658b94 5587 break;
db230ce3 5588
40658b94
PH
5589 string1 += 1;
5590 string2 += 1;
5591 }
db230ce3 5592
40658b94
PH
5593 switch (*string1)
5594 {
5595 case '(':
5596 return strcmp_iw_ordered (string1, string2);
5597 case '_':
5598 if (*string2 == '\0')
5599 {
052874e8 5600 if (is_name_suffix (string1))
40658b94
PH
5601 return 0;
5602 else
1a1d5513 5603 return 1;
40658b94 5604 }
dbb8534f 5605 /* FALLTHROUGH */
40658b94
PH
5606 default:
5607 if (*string2 == '(')
5608 return strcmp_iw_ordered (string1, string2);
5609 else
db230ce3
JB
5610 {
5611 if (casing == case_sensitive_off)
5612 return tolower (*string1) - tolower (*string2);
5613 else
5614 return *string1 - *string2;
5615 }
40658b94 5616 }
ccefe4c4
TT
5617}
5618
db230ce3
JB
5619/* Compare STRING1 to STRING2, with results as for strcmp.
5620 Compatible with strcmp_iw_ordered in that...
5621
5622 strcmp_iw_ordered (STRING1, STRING2) <= 0
5623
5624 ... implies...
5625
5626 compare_names (STRING1, STRING2) <= 0
5627
5628 (they may differ as to what symbols compare equal). */
5629
5630static int
5631compare_names (const char *string1, const char *string2)
5632{
5633 int result;
5634
5635 /* Similar to what strcmp_iw_ordered does, we need to perform
5636 a case-insensitive comparison first, and only resort to
5637 a second, case-sensitive, comparison if the first one was
5638 not sufficient to differentiate the two strings. */
5639
5640 result = compare_names_with_case (string1, string2, case_sensitive_off);
5641 if (result == 0)
5642 result = compare_names_with_case (string1, string2, case_sensitive_on);
5643
5644 return result;
5645}
5646
339c13b6
JB
5647/* Add to OBSTACKP all non-local symbols whose name and domain match
5648 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5649 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5650
5651static void
40658b94
PH
5652add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5653 domain_enum domain, int global,
5654 int is_wild_match)
339c13b6
JB
5655{
5656 struct objfile *objfile;
22cee43f 5657 struct compunit_symtab *cu;
40658b94 5658 struct match_data data;
339c13b6 5659
6475f2fe 5660 memset (&data, 0, sizeof data);
ccefe4c4 5661 data.obstackp = obstackp;
339c13b6 5662
ccefe4c4 5663 ALL_OBJFILES (objfile)
40658b94
PH
5664 {
5665 data.objfile = objfile;
5666
5667 if (is_wild_match)
4186eb54
KS
5668 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5669 aux_add_nonlocal_symbols, &data,
5670 wild_match, NULL);
40658b94 5671 else
4186eb54
KS
5672 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5673 aux_add_nonlocal_symbols, &data,
5674 full_match, compare_names);
22cee43f
PMR
5675
5676 ALL_OBJFILE_COMPUNITS (objfile, cu)
5677 {
5678 const struct block *global_block
5679 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5680
5681 if (ada_add_block_renamings (obstackp, global_block , name, domain,
5682 is_wild_match))
5683 data.found_sym = 1;
5684 }
40658b94
PH
5685 }
5686
5687 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5688 {
5689 ALL_OBJFILES (objfile)
5690 {
224c3ddb 5691 char *name1 = (char *) alloca (strlen (name) + sizeof ("_ada_"));
40658b94
PH
5692 strcpy (name1, "_ada_");
5693 strcpy (name1 + sizeof ("_ada_") - 1, name);
5694 data.objfile = objfile;
ade7ed9e
DE
5695 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5696 global,
0963b4bd
MS
5697 aux_add_nonlocal_symbols,
5698 &data,
40658b94
PH
5699 full_match, compare_names);
5700 }
5701 }
339c13b6
JB
5702}
5703
22cee43f 5704/* Find symbols in DOMAIN matching NAME, in BLOCK and, if FULL_SEARCH is
4eeaa230 5705 non-zero, enclosing scope and in global scopes, returning the number of
22cee43f 5706 matches. Add these to OBSTACKP.
4eeaa230 5707
22cee43f
PMR
5708 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5709 symbol match within the nest of blocks whose innermost member is BLOCK,
4c4b4cd2 5710 is the one match returned (no other matches in that or
d9680e73 5711 enclosing blocks is returned). If there are any matches in or
22cee43f 5712 surrounding BLOCK, then these alone are returned.
4eeaa230 5713
9f88c959 5714 Names prefixed with "standard__" are handled specially: "standard__"
22cee43f 5715 is first stripped off, and only static and global symbols are searched.
14f9c5c9 5716
22cee43f
PMR
5717 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5718 to lookup global symbols. */
5719
5720static void
5721ada_add_all_symbols (struct obstack *obstackp,
5722 const struct block *block,
5723 const char *name,
5724 domain_enum domain,
5725 int full_search,
5726 int *made_global_lookup_p)
14f9c5c9
AS
5727{
5728 struct symbol *sym;
22cee43f 5729 const int wild_match_p = should_use_wild_match (name);
14f9c5c9 5730
22cee43f
PMR
5731 if (made_global_lookup_p)
5732 *made_global_lookup_p = 0;
339c13b6
JB
5733
5734 /* Special case: If the user specifies a symbol name inside package
5735 Standard, do a non-wild matching of the symbol name without
5736 the "standard__" prefix. This was primarily introduced in order
5737 to allow the user to specifically access the standard exceptions
5738 using, for instance, Standard.Constraint_Error when Constraint_Error
5739 is ambiguous (due to the user defining its own Constraint_Error
5740 entity inside its program). */
22cee43f 5741 if (startswith (name, "standard__"))
4c4b4cd2 5742 {
4c4b4cd2 5743 block = NULL;
22cee43f 5744 name = name + sizeof ("standard__") - 1;
4c4b4cd2
PH
5745 }
5746
339c13b6 5747 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5748
4eeaa230
DE
5749 if (block != NULL)
5750 {
5751 if (full_search)
22cee43f 5752 ada_add_local_symbols (obstackp, name, block, domain, wild_match_p);
4eeaa230
DE
5753 else
5754 {
5755 /* In the !full_search case we're are being called by
5756 ada_iterate_over_symbols, and we don't want to search
5757 superblocks. */
22cee43f
PMR
5758 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5759 wild_match_p);
4eeaa230 5760 }
22cee43f
PMR
5761 if (num_defns_collected (obstackp) > 0 || !full_search)
5762 return;
4eeaa230 5763 }
d2e4a39e 5764
339c13b6
JB
5765 /* No non-global symbols found. Check our cache to see if we have
5766 already performed this search before. If we have, then return
5767 the same result. */
5768
22cee43f 5769 if (lookup_cached_symbol (name, domain, &sym, &block))
4c4b4cd2
PH
5770 {
5771 if (sym != NULL)
22cee43f
PMR
5772 add_defn_to_vec (obstackp, sym, block);
5773 return;
4c4b4cd2 5774 }
14f9c5c9 5775
22cee43f
PMR
5776 if (made_global_lookup_p)
5777 *made_global_lookup_p = 1;
b1eedac9 5778
339c13b6
JB
5779 /* Search symbols from all global blocks. */
5780
22cee43f 5781 add_nonlocal_symbols (obstackp, name, domain, 1, wild_match_p);
d2e4a39e 5782
4c4b4cd2 5783 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5784 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5785
22cee43f
PMR
5786 if (num_defns_collected (obstackp) == 0)
5787 add_nonlocal_symbols (obstackp, name, domain, 0, wild_match_p);
5788}
5789
5790/* Find symbols in DOMAIN matching NAME, in BLOCK and, if full_search is
5791 non-zero, enclosing scope and in global scopes, returning the number of
5792 matches.
5793 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5794 indicating the symbols found and the blocks and symbol tables (if
5795 any) in which they were found. This vector is transient---good only to
5796 the next call of ada_lookup_symbol_list.
5797
5798 When full_search is non-zero, any non-function/non-enumeral
5799 symbol match within the nest of blocks whose innermost member is BLOCK,
5800 is the one match returned (no other matches in that or
5801 enclosing blocks is returned). If there are any matches in or
5802 surrounding BLOCK, then these alone are returned.
5803
5804 Names prefixed with "standard__" are handled specially: "standard__"
5805 is first stripped off, and only static and global symbols are searched. */
5806
5807static int
5808ada_lookup_symbol_list_worker (const char *name, const struct block *block,
5809 domain_enum domain,
5810 struct block_symbol **results,
5811 int full_search)
5812{
5813 const int wild_match_p = should_use_wild_match (name);
5814 int syms_from_global_search;
5815 int ndefns;
5816
5817 obstack_free (&symbol_list_obstack, NULL);
5818 obstack_init (&symbol_list_obstack);
5819 ada_add_all_symbols (&symbol_list_obstack, block, name, domain,
5820 full_search, &syms_from_global_search);
14f9c5c9 5821
4c4b4cd2
PH
5822 ndefns = num_defns_collected (&symbol_list_obstack);
5823 *results = defns_collected (&symbol_list_obstack, 1);
5824
5825 ndefns = remove_extra_symbols (*results, ndefns);
5826
b1eedac9 5827 if (ndefns == 0 && full_search && syms_from_global_search)
22cee43f 5828 cache_symbol (name, domain, NULL, NULL);
14f9c5c9 5829
b1eedac9 5830 if (ndefns == 1 && full_search && syms_from_global_search)
22cee43f 5831 cache_symbol (name, domain, (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5832
22cee43f 5833 ndefns = remove_irrelevant_renamings (*results, ndefns, block);
14f9c5c9
AS
5834 return ndefns;
5835}
5836
4eeaa230
DE
5837/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5838 in global scopes, returning the number of matches, and setting *RESULTS
5839 to a vector of (SYM,BLOCK) tuples.
5840 See ada_lookup_symbol_list_worker for further details. */
5841
5842int
5843ada_lookup_symbol_list (const char *name0, const struct block *block0,
d12307c1 5844 domain_enum domain, struct block_symbol **results)
4eeaa230
DE
5845{
5846 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5847}
5848
5849/* Implementation of the la_iterate_over_symbols method. */
5850
5851static void
14bc53a8
PA
5852ada_iterate_over_symbols
5853 (const struct block *block, const char *name, domain_enum domain,
5854 gdb::function_view<symbol_found_callback_ftype> callback)
4eeaa230
DE
5855{
5856 int ndefs, i;
d12307c1 5857 struct block_symbol *results;
4eeaa230
DE
5858
5859 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5860 for (i = 0; i < ndefs; ++i)
5861 {
14bc53a8 5862 if (!callback (results[i].symbol))
4eeaa230
DE
5863 break;
5864 }
5865}
5866
f8eba3c6 5867/* If NAME is the name of an entity, return a string that should
2f408ecb 5868 be used to look that entity up in Ada units.
f8eba3c6
TT
5869
5870 NAME can have any form that the "break" or "print" commands might
5871 recognize. In other words, it does not have to be the "natural"
5872 name, or the "encoded" name. */
5873
2f408ecb 5874std::string
f8eba3c6
TT
5875ada_name_for_lookup (const char *name)
5876{
f8eba3c6
TT
5877 int nlen = strlen (name);
5878
5879 if (name[0] == '<' && name[nlen - 1] == '>')
2f408ecb 5880 return std::string (name + 1, nlen - 2);
f8eba3c6 5881 else
2f408ecb 5882 return ada_encode (ada_fold_name (name));
f8eba3c6
TT
5883}
5884
4e5c77fe
JB
5885/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5886 to 1, but choosing the first symbol found if there are multiple
5887 choices.
5888
5e2336be
JB
5889 The result is stored in *INFO, which must be non-NULL.
5890 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5891
5892void
5893ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5894 domain_enum domain,
d12307c1 5895 struct block_symbol *info)
14f9c5c9 5896{
d12307c1 5897 struct block_symbol *candidates;
14f9c5c9
AS
5898 int n_candidates;
5899
5e2336be 5900 gdb_assert (info != NULL);
d12307c1 5901 memset (info, 0, sizeof (struct block_symbol));
4e5c77fe 5902
fe978cb0 5903 n_candidates = ada_lookup_symbol_list (name, block, domain, &candidates);
14f9c5c9 5904 if (n_candidates == 0)
4e5c77fe 5905 return;
4c4b4cd2 5906
5e2336be 5907 *info = candidates[0];
d12307c1 5908 info->symbol = fixup_symbol_section (info->symbol, NULL);
4e5c77fe 5909}
aeb5907d
JB
5910
5911/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5912 scope and in global scopes, or NULL if none. NAME is folded and
5913 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5914 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5915 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5916
d12307c1 5917struct block_symbol
aeb5907d 5918ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5919 domain_enum domain, int *is_a_field_of_this)
aeb5907d 5920{
d12307c1 5921 struct block_symbol info;
4e5c77fe 5922
aeb5907d
JB
5923 if (is_a_field_of_this != NULL)
5924 *is_a_field_of_this = 0;
5925
4e5c77fe 5926 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
fe978cb0 5927 block0, domain, &info);
d12307c1 5928 return info;
4c4b4cd2 5929}
14f9c5c9 5930
d12307c1 5931static struct block_symbol
f606139a
DE
5932ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5933 const char *name,
76a01679 5934 const struct block *block,
21b556f4 5935 const domain_enum domain)
4c4b4cd2 5936{
d12307c1 5937 struct block_symbol sym;
04dccad0
JB
5938
5939 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5940 if (sym.symbol != NULL)
04dccad0
JB
5941 return sym;
5942
5943 /* If we haven't found a match at this point, try the primitive
5944 types. In other languages, this search is performed before
5945 searching for global symbols in order to short-circuit that
5946 global-symbol search if it happens that the name corresponds
5947 to a primitive type. But we cannot do the same in Ada, because
5948 it is perfectly legitimate for a program to declare a type which
5949 has the same name as a standard type. If looking up a type in
5950 that situation, we have traditionally ignored the primitive type
5951 in favor of user-defined types. This is why, unlike most other
5952 languages, we search the primitive types this late and only after
5953 having searched the global symbols without success. */
5954
5955 if (domain == VAR_DOMAIN)
5956 {
5957 struct gdbarch *gdbarch;
5958
5959 if (block == NULL)
5960 gdbarch = target_gdbarch ();
5961 else
5962 gdbarch = block_gdbarch (block);
d12307c1
PMR
5963 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5964 if (sym.symbol != NULL)
04dccad0
JB
5965 return sym;
5966 }
5967
d12307c1 5968 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5969}
5970
5971
4c4b4cd2
PH
5972/* True iff STR is a possible encoded suffix of a normal Ada name
5973 that is to be ignored for matching purposes. Suffixes of parallel
5974 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5975 are given by any of the regular expressions:
4c4b4cd2 5976
babe1480
JB
5977 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5978 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5979 TKB [subprogram suffix for task bodies]
babe1480 5980 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5981 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5982
5983 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5984 match is performed. This sequence is used to differentiate homonyms,
5985 is an optional part of a valid name suffix. */
4c4b4cd2 5986
14f9c5c9 5987static int
d2e4a39e 5988is_name_suffix (const char *str)
14f9c5c9
AS
5989{
5990 int k;
4c4b4cd2
PH
5991 const char *matching;
5992 const int len = strlen (str);
5993
babe1480
JB
5994 /* Skip optional leading __[0-9]+. */
5995
4c4b4cd2
PH
5996 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5997 {
babe1480
JB
5998 str += 3;
5999 while (isdigit (str[0]))
6000 str += 1;
4c4b4cd2 6001 }
babe1480
JB
6002
6003 /* [.$][0-9]+ */
4c4b4cd2 6004
babe1480 6005 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 6006 {
babe1480 6007 matching = str + 1;
4c4b4cd2
PH
6008 while (isdigit (matching[0]))
6009 matching += 1;
6010 if (matching[0] == '\0')
6011 return 1;
6012 }
6013
6014 /* ___[0-9]+ */
babe1480 6015
4c4b4cd2
PH
6016 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6017 {
6018 matching = str + 3;
6019 while (isdigit (matching[0]))
6020 matching += 1;
6021 if (matching[0] == '\0')
6022 return 1;
6023 }
6024
9ac7f98e
JB
6025 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6026
6027 if (strcmp (str, "TKB") == 0)
6028 return 1;
6029
529cad9c
PH
6030#if 0
6031 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
6032 with a N at the end. Unfortunately, the compiler uses the same
6033 convention for other internal types it creates. So treating
529cad9c 6034 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
6035 some regressions. For instance, consider the case of an enumerated
6036 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
6037 name ends with N.
6038 Having a single character like this as a suffix carrying some
0963b4bd 6039 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
6040 to be something like "_N" instead. In the meantime, do not do
6041 the following check. */
6042 /* Protected Object Subprograms */
6043 if (len == 1 && str [0] == 'N')
6044 return 1;
6045#endif
6046
6047 /* _E[0-9]+[bs]$ */
6048 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6049 {
6050 matching = str + 3;
6051 while (isdigit (matching[0]))
6052 matching += 1;
6053 if ((matching[0] == 'b' || matching[0] == 's')
6054 && matching [1] == '\0')
6055 return 1;
6056 }
6057
4c4b4cd2
PH
6058 /* ??? We should not modify STR directly, as we are doing below. This
6059 is fine in this case, but may become problematic later if we find
6060 that this alternative did not work, and want to try matching
6061 another one from the begining of STR. Since we modified it, we
6062 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
6063 if (str[0] == 'X')
6064 {
6065 str += 1;
d2e4a39e 6066 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
6067 {
6068 if (str[0] != 'n' && str[0] != 'b')
6069 return 0;
6070 str += 1;
6071 }
14f9c5c9 6072 }
babe1480 6073
14f9c5c9
AS
6074 if (str[0] == '\000')
6075 return 1;
babe1480 6076
d2e4a39e 6077 if (str[0] == '_')
14f9c5c9
AS
6078 {
6079 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 6080 return 0;
d2e4a39e 6081 if (str[2] == '_')
4c4b4cd2 6082 {
61ee279c
PH
6083 if (strcmp (str + 3, "JM") == 0)
6084 return 1;
6085 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6086 the LJM suffix in favor of the JM one. But we will
6087 still accept LJM as a valid suffix for a reasonable
6088 amount of time, just to allow ourselves to debug programs
6089 compiled using an older version of GNAT. */
4c4b4cd2
PH
6090 if (strcmp (str + 3, "LJM") == 0)
6091 return 1;
6092 if (str[3] != 'X')
6093 return 0;
1265e4aa
JB
6094 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6095 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
6096 return 1;
6097 if (str[4] == 'R' && str[5] != 'T')
6098 return 1;
6099 return 0;
6100 }
6101 if (!isdigit (str[2]))
6102 return 0;
6103 for (k = 3; str[k] != '\0'; k += 1)
6104 if (!isdigit (str[k]) && str[k] != '_')
6105 return 0;
14f9c5c9
AS
6106 return 1;
6107 }
4c4b4cd2 6108 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 6109 {
4c4b4cd2
PH
6110 for (k = 2; str[k] != '\0'; k += 1)
6111 if (!isdigit (str[k]) && str[k] != '_')
6112 return 0;
14f9c5c9
AS
6113 return 1;
6114 }
6115 return 0;
6116}
d2e4a39e 6117
aeb5907d
JB
6118/* Return non-zero if the string starting at NAME and ending before
6119 NAME_END contains no capital letters. */
529cad9c
PH
6120
6121static int
6122is_valid_name_for_wild_match (const char *name0)
6123{
6124 const char *decoded_name = ada_decode (name0);
6125 int i;
6126
5823c3ef
JB
6127 /* If the decoded name starts with an angle bracket, it means that
6128 NAME0 does not follow the GNAT encoding format. It should then
6129 not be allowed as a possible wild match. */
6130 if (decoded_name[0] == '<')
6131 return 0;
6132
529cad9c
PH
6133 for (i=0; decoded_name[i] != '\0'; i++)
6134 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6135 return 0;
6136
6137 return 1;
6138}
6139
73589123
PH
6140/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6141 that could start a simple name. Assumes that *NAMEP points into
6142 the string beginning at NAME0. */
4c4b4cd2 6143
14f9c5c9 6144static int
73589123 6145advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 6146{
73589123 6147 const char *name = *namep;
5b4ee69b 6148
5823c3ef 6149 while (1)
14f9c5c9 6150 {
aa27d0b3 6151 int t0, t1;
73589123
PH
6152
6153 t0 = *name;
6154 if (t0 == '_')
6155 {
6156 t1 = name[1];
6157 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6158 {
6159 name += 1;
61012eef 6160 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
6161 break;
6162 else
6163 name += 1;
6164 }
aa27d0b3
JB
6165 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6166 || name[2] == target0))
73589123
PH
6167 {
6168 name += 2;
6169 break;
6170 }
6171 else
6172 return 0;
6173 }
6174 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6175 name += 1;
6176 else
5823c3ef 6177 return 0;
73589123
PH
6178 }
6179
6180 *namep = name;
6181 return 1;
6182}
6183
6184/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
6185 informational suffixes of NAME (i.e., for which is_name_suffix is
6186 true). Assumes that PATN is a lower-cased Ada simple name. */
6187
6188static int
6189wild_match (const char *name, const char *patn)
6190{
22e048c9 6191 const char *p;
73589123
PH
6192 const char *name0 = name;
6193
6194 while (1)
6195 {
6196 const char *match = name;
6197
6198 if (*name == *patn)
6199 {
6200 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6201 if (*p != *name)
6202 break;
6203 if (*p == '\0' && is_name_suffix (name))
6204 return match != name0 && !is_valid_name_for_wild_match (name0);
6205
6206 if (name[-1] == '_')
6207 name -= 1;
6208 }
6209 if (!advance_wild_match (&name, name0, *patn))
6210 return 1;
96d887e8 6211 }
96d887e8
PH
6212}
6213
40658b94
PH
6214/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
6215 informational suffix. */
6216
c4d840bd
PH
6217static int
6218full_match (const char *sym_name, const char *search_name)
6219{
40658b94 6220 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
6221}
6222
6223
96d887e8
PH
6224/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
6225 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 6226 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 6227 OBJFILE is the section containing BLOCK. */
96d887e8
PH
6228
6229static void
6230ada_add_block_symbols (struct obstack *obstackp,
f0c5f9b2 6231 const struct block *block, const char *name,
96d887e8 6232 domain_enum domain, struct objfile *objfile,
2570f2b7 6233 int wild)
96d887e8 6234{
8157b174 6235 struct block_iterator iter;
96d887e8
PH
6236 int name_len = strlen (name);
6237 /* A matching argument symbol, if any. */
6238 struct symbol *arg_sym;
6239 /* Set true when we find a matching non-argument symbol. */
6240 int found_sym;
6241 struct symbol *sym;
6242
6243 arg_sym = NULL;
6244 found_sym = 0;
6245 if (wild)
6246 {
8157b174
TT
6247 for (sym = block_iter_match_first (block, name, wild_match, &iter);
6248 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 6249 {
4186eb54
KS
6250 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6251 SYMBOL_DOMAIN (sym), domain)
73589123 6252 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 6253 {
2a2d4dc3
AS
6254 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
6255 continue;
6256 else if (SYMBOL_IS_ARGUMENT (sym))
6257 arg_sym = sym;
6258 else
6259 {
76a01679
JB
6260 found_sym = 1;
6261 add_defn_to_vec (obstackp,
6262 fixup_symbol_section (sym, objfile),
2570f2b7 6263 block);
76a01679
JB
6264 }
6265 }
6266 }
96d887e8
PH
6267 }
6268 else
6269 {
8157b174
TT
6270 for (sym = block_iter_match_first (block, name, full_match, &iter);
6271 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 6272 {
4186eb54
KS
6273 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6274 SYMBOL_DOMAIN (sym), domain))
76a01679 6275 {
c4d840bd
PH
6276 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6277 {
6278 if (SYMBOL_IS_ARGUMENT (sym))
6279 arg_sym = sym;
6280 else
2a2d4dc3 6281 {
c4d840bd
PH
6282 found_sym = 1;
6283 add_defn_to_vec (obstackp,
6284 fixup_symbol_section (sym, objfile),
6285 block);
2a2d4dc3 6286 }
c4d840bd 6287 }
76a01679
JB
6288 }
6289 }
96d887e8
PH
6290 }
6291
22cee43f
PMR
6292 /* Handle renamings. */
6293
6294 if (ada_add_block_renamings (obstackp, block, name, domain, wild))
6295 found_sym = 1;
6296
96d887e8
PH
6297 if (!found_sym && arg_sym != NULL)
6298 {
76a01679
JB
6299 add_defn_to_vec (obstackp,
6300 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6301 block);
96d887e8
PH
6302 }
6303
6304 if (!wild)
6305 {
6306 arg_sym = NULL;
6307 found_sym = 0;
6308
6309 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6310 {
4186eb54
KS
6311 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6312 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6313 {
6314 int cmp;
6315
6316 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6317 if (cmp == 0)
6318 {
61012eef 6319 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6320 if (cmp == 0)
6321 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6322 name_len);
6323 }
6324
6325 if (cmp == 0
6326 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6327 {
2a2d4dc3
AS
6328 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6329 {
6330 if (SYMBOL_IS_ARGUMENT (sym))
6331 arg_sym = sym;
6332 else
6333 {
6334 found_sym = 1;
6335 add_defn_to_vec (obstackp,
6336 fixup_symbol_section (sym, objfile),
6337 block);
6338 }
6339 }
76a01679
JB
6340 }
6341 }
76a01679 6342 }
96d887e8
PH
6343
6344 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6345 They aren't parameters, right? */
6346 if (!found_sym && arg_sym != NULL)
6347 {
6348 add_defn_to_vec (obstackp,
76a01679 6349 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6350 block);
96d887e8
PH
6351 }
6352 }
6353}
6354\f
41d27058
JB
6355
6356 /* Symbol Completion */
6357
6358/* If SYM_NAME is a completion candidate for TEXT, return this symbol
6359 name in a form that's appropriate for the completion. The result
6360 does not need to be deallocated, but is only good until the next call.
6361
6362 TEXT_LEN is equal to the length of TEXT.
e701b3c0 6363 Perform a wild match if WILD_MATCH_P is set.
6ea35997 6364 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
6365 in its encoded form. */
6366
6367static const char *
6368symbol_completion_match (const char *sym_name,
6369 const char *text, int text_len,
6ea35997 6370 int wild_match_p, int encoded_p)
41d27058 6371{
41d27058
JB
6372 const int verbatim_match = (text[0] == '<');
6373 int match = 0;
6374
6375 if (verbatim_match)
6376 {
6377 /* Strip the leading angle bracket. */
6378 text = text + 1;
6379 text_len--;
6380 }
6381
6382 /* First, test against the fully qualified name of the symbol. */
6383
6384 if (strncmp (sym_name, text, text_len) == 0)
6385 match = 1;
6386
6ea35997 6387 if (match && !encoded_p)
41d27058
JB
6388 {
6389 /* One needed check before declaring a positive match is to verify
6390 that iff we are doing a verbatim match, the decoded version
6391 of the symbol name starts with '<'. Otherwise, this symbol name
6392 is not a suitable completion. */
6393 const char *sym_name_copy = sym_name;
6394 int has_angle_bracket;
6395
6396 sym_name = ada_decode (sym_name);
6397 has_angle_bracket = (sym_name[0] == '<');
6398 match = (has_angle_bracket == verbatim_match);
6399 sym_name = sym_name_copy;
6400 }
6401
6402 if (match && !verbatim_match)
6403 {
6404 /* When doing non-verbatim match, another check that needs to
6405 be done is to verify that the potentially matching symbol name
6406 does not include capital letters, because the ada-mode would
6407 not be able to understand these symbol names without the
6408 angle bracket notation. */
6409 const char *tmp;
6410
6411 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6412 if (*tmp != '\0')
6413 match = 0;
6414 }
6415
6416 /* Second: Try wild matching... */
6417
e701b3c0 6418 if (!match && wild_match_p)
41d27058
JB
6419 {
6420 /* Since we are doing wild matching, this means that TEXT
6421 may represent an unqualified symbol name. We therefore must
6422 also compare TEXT against the unqualified name of the symbol. */
6423 sym_name = ada_unqualified_name (ada_decode (sym_name));
6424
6425 if (strncmp (sym_name, text, text_len) == 0)
6426 match = 1;
6427 }
6428
6429 /* Finally: If we found a mach, prepare the result to return. */
6430
6431 if (!match)
6432 return NULL;
6433
6434 if (verbatim_match)
6435 sym_name = add_angle_brackets (sym_name);
6436
6ea35997 6437 if (!encoded_p)
41d27058
JB
6438 sym_name = ada_decode (sym_name);
6439
6440 return sym_name;
6441}
6442
6443/* A companion function to ada_make_symbol_completion_list().
6444 Check if SYM_NAME represents a symbol which name would be suitable
6445 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6446 it is appended at the end of the given string vector SV.
6447
6448 ORIG_TEXT is the string original string from the user command
6449 that needs to be completed. WORD is the entire command on which
6450 completion should be performed. These two parameters are used to
6451 determine which part of the symbol name should be added to the
6452 completion vector.
c0af1706 6453 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 6454 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
6455 encoded formed (in which case the completion should also be
6456 encoded). */
6457
6458static void
d6565258 6459symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
6460 const char *sym_name,
6461 const char *text, int text_len,
6462 const char *orig_text, const char *word,
cb8e9b97 6463 int wild_match_p, int encoded_p)
41d27058
JB
6464{
6465 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 6466 wild_match_p, encoded_p);
41d27058
JB
6467 char *completion;
6468
6469 if (match == NULL)
6470 return;
6471
6472 /* We found a match, so add the appropriate completion to the given
6473 string vector. */
6474
6475 if (word == orig_text)
6476 {
224c3ddb 6477 completion = (char *) xmalloc (strlen (match) + 5);
41d27058
JB
6478 strcpy (completion, match);
6479 }
6480 else if (word > orig_text)
6481 {
6482 /* Return some portion of sym_name. */
224c3ddb 6483 completion = (char *) xmalloc (strlen (match) + 5);
41d27058
JB
6484 strcpy (completion, match + (word - orig_text));
6485 }
6486 else
6487 {
6488 /* Return some of ORIG_TEXT plus sym_name. */
224c3ddb 6489 completion = (char *) xmalloc (strlen (match) + (orig_text - word) + 5);
41d27058
JB
6490 strncpy (completion, word, orig_text - word);
6491 completion[orig_text - word] = '\0';
6492 strcat (completion, match);
6493 }
6494
d6565258 6495 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
6496}
6497
49c4e619
TT
6498/* Return a list of possible symbol names completing TEXT0. WORD is
6499 the entire command on which completion is made. */
41d27058 6500
49c4e619 6501static VEC (char_ptr) *
6f937416
PA
6502ada_make_symbol_completion_list (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;
2ba95b9b 6509 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058 6510 struct symbol *sym;
43f3e411 6511 struct compunit_symtab *s;
41d27058
JB
6512 struct minimal_symbol *msymbol;
6513 struct objfile *objfile;
3977b71f 6514 const struct block *b, *surrounding_static_block = 0;
41d27058 6515 int i;
8157b174 6516 struct block_iterator iter;
b8fea896 6517 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6518
2f68a895
TT
6519 gdb_assert (code == TYPE_CODE_UNDEF);
6520
41d27058
JB
6521 if (text0[0] == '<')
6522 {
6523 text = xstrdup (text0);
6524 make_cleanup (xfree, text);
6525 text_len = strlen (text);
b1ed564a
JB
6526 wild_match_p = 0;
6527 encoded_p = 1;
41d27058
JB
6528 }
6529 else
6530 {
6531 text = xstrdup (ada_encode (text0));
6532 make_cleanup (xfree, text);
6533 text_len = strlen (text);
6534 for (i = 0; i < text_len; i++)
6535 text[i] = tolower (text[i]);
6536
b1ed564a 6537 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
6538 /* If the name contains a ".", then the user is entering a fully
6539 qualified entity name, and the match must not be done in wild
6540 mode. Similarly, if the user wants to complete what looks like
6541 an encoded name, the match must not be done in wild mode. */
b1ed564a 6542 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
6543 }
6544
6545 /* First, look at the partial symtab symbols. */
14bc53a8
PA
6546 expand_symtabs_matching (NULL,
6547 [&] (const char *symname)
6548 {
6549 return symbol_completion_match (symname,
6550 text, text_len,
6551 wild_match_p,
6552 encoded_p);
6553 },
6554 NULL,
6555 ALL_DOMAIN);
41d27058
JB
6556
6557 /* At this point scan through the misc symbol vectors and add each
6558 symbol you find to the list. Eventually we want to ignore
6559 anything that isn't a text symbol (everything else will be
6560 handled by the psymtab code above). */
6561
6562 ALL_MSYMBOLS (objfile, msymbol)
6563 {
6564 QUIT;
efd66ac6 6565 symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
6566 text, text_len, text0, word, wild_match_p,
6567 encoded_p);
41d27058
JB
6568 }
6569
6570 /* Search upwards from currently selected frame (so that we can
6571 complete on local vars. */
6572
6573 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6574 {
6575 if (!BLOCK_SUPERBLOCK (b))
6576 surrounding_static_block = b; /* For elmin of dups */
6577
6578 ALL_BLOCK_SYMBOLS (b, iter, sym)
6579 {
d6565258 6580 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6581 text, text_len, text0, word,
b1ed564a 6582 wild_match_p, encoded_p);
41d27058
JB
6583 }
6584 }
6585
6586 /* Go through the symtabs and check the externs and statics for
43f3e411 6587 symbols which match. */
41d27058 6588
43f3e411 6589 ALL_COMPUNITS (objfile, s)
41d27058
JB
6590 {
6591 QUIT;
43f3e411 6592 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6593 ALL_BLOCK_SYMBOLS (b, iter, sym)
6594 {
d6565258 6595 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6596 text, text_len, text0, word,
b1ed564a 6597 wild_match_p, encoded_p);
41d27058
JB
6598 }
6599 }
6600
43f3e411 6601 ALL_COMPUNITS (objfile, s)
41d27058
JB
6602 {
6603 QUIT;
43f3e411 6604 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6605 /* Don't do this block twice. */
6606 if (b == surrounding_static_block)
6607 continue;
6608 ALL_BLOCK_SYMBOLS (b, iter, sym)
6609 {
d6565258 6610 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6611 text, text_len, text0, word,
b1ed564a 6612 wild_match_p, encoded_p);
41d27058
JB
6613 }
6614 }
6615
b8fea896 6616 do_cleanups (old_chain);
49c4e619 6617 return completions;
41d27058
JB
6618}
6619
963a6417 6620 /* Field Access */
96d887e8 6621
73fb9985
JB
6622/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6623 for tagged types. */
6624
6625static int
6626ada_is_dispatch_table_ptr_type (struct type *type)
6627{
0d5cff50 6628 const char *name;
73fb9985
JB
6629
6630 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6631 return 0;
6632
6633 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6634 if (name == NULL)
6635 return 0;
6636
6637 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6638}
6639
ac4a2da4
JG
6640/* Return non-zero if TYPE is an interface tag. */
6641
6642static int
6643ada_is_interface_tag (struct type *type)
6644{
6645 const char *name = TYPE_NAME (type);
6646
6647 if (name == NULL)
6648 return 0;
6649
6650 return (strcmp (name, "ada__tags__interface_tag") == 0);
6651}
6652
963a6417
PH
6653/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6654 to be invisible to users. */
96d887e8 6655
963a6417
PH
6656int
6657ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6658{
963a6417
PH
6659 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6660 return 1;
ffde82bf 6661
73fb9985
JB
6662 /* Check the name of that field. */
6663 {
6664 const char *name = TYPE_FIELD_NAME (type, field_num);
6665
6666 /* Anonymous field names should not be printed.
6667 brobecker/2007-02-20: I don't think this can actually happen
6668 but we don't want to print the value of annonymous fields anyway. */
6669 if (name == NULL)
6670 return 1;
6671
ffde82bf
JB
6672 /* Normally, fields whose name start with an underscore ("_")
6673 are fields that have been internally generated by the compiler,
6674 and thus should not be printed. The "_parent" field is special,
6675 however: This is a field internally generated by the compiler
6676 for tagged types, and it contains the components inherited from
6677 the parent type. This field should not be printed as is, but
6678 should not be ignored either. */
61012eef 6679 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6680 return 1;
6681 }
6682
ac4a2da4
JG
6683 /* If this is the dispatch table of a tagged type or an interface tag,
6684 then ignore. */
73fb9985 6685 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6686 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6687 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6688 return 1;
6689
6690 /* Not a special field, so it should not be ignored. */
6691 return 0;
963a6417 6692}
96d887e8 6693
963a6417 6694/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6695 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6696
963a6417
PH
6697int
6698ada_is_tagged_type (struct type *type, int refok)
6699{
6700 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6701}
96d887e8 6702
963a6417 6703/* True iff TYPE represents the type of X'Tag */
96d887e8 6704
963a6417
PH
6705int
6706ada_is_tag_type (struct type *type)
6707{
460efde1
JB
6708 type = ada_check_typedef (type);
6709
963a6417
PH
6710 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6711 return 0;
6712 else
96d887e8 6713 {
963a6417 6714 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6715
963a6417
PH
6716 return (name != NULL
6717 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6718 }
96d887e8
PH
6719}
6720
963a6417 6721/* The type of the tag on VAL. */
76a01679 6722
963a6417
PH
6723struct type *
6724ada_tag_type (struct value *val)
96d887e8 6725{
df407dfe 6726 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6727}
96d887e8 6728
b50d69b5
JG
6729/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6730 retired at Ada 05). */
6731
6732static int
6733is_ada95_tag (struct value *tag)
6734{
6735 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6736}
6737
963a6417 6738/* The value of the tag on VAL. */
96d887e8 6739
963a6417
PH
6740struct value *
6741ada_value_tag (struct value *val)
6742{
03ee6b2e 6743 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6744}
6745
963a6417
PH
6746/* The value of the tag on the object of type TYPE whose contents are
6747 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6748 ADDRESS. */
96d887e8 6749
963a6417 6750static struct value *
10a2c479 6751value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6752 const gdb_byte *valaddr,
963a6417 6753 CORE_ADDR address)
96d887e8 6754{
b5385fc0 6755 int tag_byte_offset;
963a6417 6756 struct type *tag_type;
5b4ee69b 6757
963a6417 6758 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6759 NULL, NULL, NULL))
96d887e8 6760 {
fc1a4b47 6761 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6762 ? NULL
6763 : valaddr + tag_byte_offset);
963a6417 6764 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6765
963a6417 6766 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6767 }
963a6417
PH
6768 return NULL;
6769}
96d887e8 6770
963a6417
PH
6771static struct type *
6772type_from_tag (struct value *tag)
6773{
6774 const char *type_name = ada_tag_name (tag);
5b4ee69b 6775
963a6417
PH
6776 if (type_name != NULL)
6777 return ada_find_any_type (ada_encode (type_name));
6778 return NULL;
6779}
96d887e8 6780
b50d69b5
JG
6781/* Given a value OBJ of a tagged type, return a value of this
6782 type at the base address of the object. The base address, as
6783 defined in Ada.Tags, it is the address of the primary tag of
6784 the object, and therefore where the field values of its full
6785 view can be fetched. */
6786
6787struct value *
6788ada_tag_value_at_base_address (struct value *obj)
6789{
b50d69b5
JG
6790 struct value *val;
6791 LONGEST offset_to_top = 0;
6792 struct type *ptr_type, *obj_type;
6793 struct value *tag;
6794 CORE_ADDR base_address;
6795
6796 obj_type = value_type (obj);
6797
6798 /* It is the responsability of the caller to deref pointers. */
6799
6800 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6801 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6802 return obj;
6803
6804 tag = ada_value_tag (obj);
6805 if (!tag)
6806 return obj;
6807
6808 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6809
6810 if (is_ada95_tag (tag))
6811 return obj;
6812
6813 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6814 ptr_type = lookup_pointer_type (ptr_type);
6815 val = value_cast (ptr_type, tag);
6816 if (!val)
6817 return obj;
6818
6819 /* It is perfectly possible that an exception be raised while
6820 trying to determine the base address, just like for the tag;
6821 see ada_tag_name for more details. We do not print the error
6822 message for the same reason. */
6823
492d29ea 6824 TRY
b50d69b5
JG
6825 {
6826 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6827 }
6828
492d29ea
PA
6829 CATCH (e, RETURN_MASK_ERROR)
6830 {
6831 return obj;
6832 }
6833 END_CATCH
b50d69b5
JG
6834
6835 /* If offset is null, nothing to do. */
6836
6837 if (offset_to_top == 0)
6838 return obj;
6839
6840 /* -1 is a special case in Ada.Tags; however, what should be done
6841 is not quite clear from the documentation. So do nothing for
6842 now. */
6843
6844 if (offset_to_top == -1)
6845 return obj;
6846
6847 base_address = value_address (obj) - offset_to_top;
6848 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6849
6850 /* Make sure that we have a proper tag at the new address.
6851 Otherwise, offset_to_top is bogus (which can happen when
6852 the object is not initialized yet). */
6853
6854 if (!tag)
6855 return obj;
6856
6857 obj_type = type_from_tag (tag);
6858
6859 if (!obj_type)
6860 return obj;
6861
6862 return value_from_contents_and_address (obj_type, NULL, base_address);
6863}
6864
1b611343
JB
6865/* Return the "ada__tags__type_specific_data" type. */
6866
6867static struct type *
6868ada_get_tsd_type (struct inferior *inf)
963a6417 6869{
1b611343 6870 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6871
1b611343
JB
6872 if (data->tsd_type == 0)
6873 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6874 return data->tsd_type;
6875}
529cad9c 6876
1b611343
JB
6877/* Return the TSD (type-specific data) associated to the given TAG.
6878 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6879
1b611343 6880 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6881
1b611343
JB
6882static struct value *
6883ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6884{
4c4b4cd2 6885 struct value *val;
1b611343 6886 struct type *type;
5b4ee69b 6887
1b611343
JB
6888 /* First option: The TSD is simply stored as a field of our TAG.
6889 Only older versions of GNAT would use this format, but we have
6890 to test it first, because there are no visible markers for
6891 the current approach except the absence of that field. */
529cad9c 6892
1b611343
JB
6893 val = ada_value_struct_elt (tag, "tsd", 1);
6894 if (val)
6895 return val;
e802dbe0 6896
1b611343
JB
6897 /* Try the second representation for the dispatch table (in which
6898 there is no explicit 'tsd' field in the referent of the tag pointer,
6899 and instead the tsd pointer is stored just before the dispatch
6900 table. */
e802dbe0 6901
1b611343
JB
6902 type = ada_get_tsd_type (current_inferior());
6903 if (type == NULL)
6904 return NULL;
6905 type = lookup_pointer_type (lookup_pointer_type (type));
6906 val = value_cast (type, tag);
6907 if (val == NULL)
6908 return NULL;
6909 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6910}
6911
1b611343
JB
6912/* Given the TSD of a tag (type-specific data), return a string
6913 containing the name of the associated type.
6914
6915 The returned value is good until the next call. May return NULL
6916 if we are unable to determine the tag name. */
6917
6918static char *
6919ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6920{
529cad9c
PH
6921 static char name[1024];
6922 char *p;
1b611343 6923 struct value *val;
529cad9c 6924
1b611343 6925 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6926 if (val == NULL)
1b611343 6927 return NULL;
4c4b4cd2
PH
6928 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6929 for (p = name; *p != '\0'; p += 1)
6930 if (isalpha (*p))
6931 *p = tolower (*p);
1b611343 6932 return name;
4c4b4cd2
PH
6933}
6934
6935/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6936 a C string.
6937
6938 Return NULL if the TAG is not an Ada tag, or if we were unable to
6939 determine the name of that tag. The result is good until the next
6940 call. */
4c4b4cd2
PH
6941
6942const char *
6943ada_tag_name (struct value *tag)
6944{
1b611343 6945 char *name = NULL;
5b4ee69b 6946
df407dfe 6947 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6948 return NULL;
1b611343
JB
6949
6950 /* It is perfectly possible that an exception be raised while trying
6951 to determine the TAG's name, even under normal circumstances:
6952 The associated variable may be uninitialized or corrupted, for
6953 instance. We do not let any exception propagate past this point.
6954 instead we return NULL.
6955
6956 We also do not print the error message either (which often is very
6957 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6958 the caller print a more meaningful message if necessary. */
492d29ea 6959 TRY
1b611343
JB
6960 {
6961 struct value *tsd = ada_get_tsd_from_tag (tag);
6962
6963 if (tsd != NULL)
6964 name = ada_tag_name_from_tsd (tsd);
6965 }
492d29ea
PA
6966 CATCH (e, RETURN_MASK_ERROR)
6967 {
6968 }
6969 END_CATCH
1b611343
JB
6970
6971 return name;
4c4b4cd2
PH
6972}
6973
6974/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6975
d2e4a39e 6976struct type *
ebf56fd3 6977ada_parent_type (struct type *type)
14f9c5c9
AS
6978{
6979 int i;
6980
61ee279c 6981 type = ada_check_typedef (type);
14f9c5c9
AS
6982
6983 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6984 return NULL;
6985
6986 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6987 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6988 {
6989 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6990
6991 /* If the _parent field is a pointer, then dereference it. */
6992 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6993 parent_type = TYPE_TARGET_TYPE (parent_type);
6994 /* If there is a parallel XVS type, get the actual base type. */
6995 parent_type = ada_get_base_type (parent_type);
6996
6997 return ada_check_typedef (parent_type);
6998 }
14f9c5c9
AS
6999
7000 return NULL;
7001}
7002
4c4b4cd2
PH
7003/* True iff field number FIELD_NUM of structure type TYPE contains the
7004 parent-type (inherited) fields of a derived type. Assumes TYPE is
7005 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
7006
7007int
ebf56fd3 7008ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 7009{
61ee279c 7010 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 7011
4c4b4cd2 7012 return (name != NULL
61012eef
GB
7013 && (startswith (name, "PARENT")
7014 || startswith (name, "_parent")));
14f9c5c9
AS
7015}
7016
4c4b4cd2 7017/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 7018 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 7019 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 7020 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 7021 structures. */
14f9c5c9
AS
7022
7023int
ebf56fd3 7024ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 7025{
d2e4a39e 7026 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 7027
dddc0e16
JB
7028 if (name != NULL && strcmp (name, "RETVAL") == 0)
7029 {
7030 /* This happens in functions with "out" or "in out" parameters
7031 which are passed by copy. For such functions, GNAT describes
7032 the function's return type as being a struct where the return
7033 value is in a field called RETVAL, and where the other "out"
7034 or "in out" parameters are fields of that struct. This is not
7035 a wrapper. */
7036 return 0;
7037 }
7038
d2e4a39e 7039 return (name != NULL
61012eef 7040 && (startswith (name, "PARENT")
4c4b4cd2 7041 || strcmp (name, "REP") == 0
61012eef 7042 || startswith (name, "_parent")
4c4b4cd2 7043 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
7044}
7045
4c4b4cd2
PH
7046/* True iff field number FIELD_NUM of structure or union type TYPE
7047 is a variant wrapper. Assumes TYPE is a structure type with at least
7048 FIELD_NUM+1 fields. */
14f9c5c9
AS
7049
7050int
ebf56fd3 7051ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 7052{
d2e4a39e 7053 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 7054
14f9c5c9 7055 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 7056 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
7057 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
7058 == TYPE_CODE_UNION)));
14f9c5c9
AS
7059}
7060
7061/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 7062 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
7063 returns the type of the controlling discriminant for the variant.
7064 May return NULL if the type could not be found. */
14f9c5c9 7065
d2e4a39e 7066struct type *
ebf56fd3 7067ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 7068{
a121b7c1 7069 const char *name = ada_variant_discrim_name (var_type);
5b4ee69b 7070
7c964f07 7071 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
7072}
7073
4c4b4cd2 7074/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 7075 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 7076 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
7077
7078int
ebf56fd3 7079ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 7080{
d2e4a39e 7081 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 7082
14f9c5c9
AS
7083 return (name != NULL && name[0] == 'O');
7084}
7085
7086/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
7087 returns the name of the discriminant controlling the variant.
7088 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 7089
a121b7c1 7090const char *
ebf56fd3 7091ada_variant_discrim_name (struct type *type0)
14f9c5c9 7092{
d2e4a39e 7093 static char *result = NULL;
14f9c5c9 7094 static size_t result_len = 0;
d2e4a39e
AS
7095 struct type *type;
7096 const char *name;
7097 const char *discrim_end;
7098 const char *discrim_start;
14f9c5c9
AS
7099
7100 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7101 type = TYPE_TARGET_TYPE (type0);
7102 else
7103 type = type0;
7104
7105 name = ada_type_name (type);
7106
7107 if (name == NULL || name[0] == '\000')
7108 return "";
7109
7110 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7111 discrim_end -= 1)
7112 {
61012eef 7113 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 7114 break;
14f9c5c9
AS
7115 }
7116 if (discrim_end == name)
7117 return "";
7118
d2e4a39e 7119 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
7120 discrim_start -= 1)
7121 {
d2e4a39e 7122 if (discrim_start == name + 1)
4c4b4cd2 7123 return "";
76a01679 7124 if ((discrim_start > name + 3
61012eef 7125 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
7126 || discrim_start[-1] == '.')
7127 break;
14f9c5c9
AS
7128 }
7129
7130 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7131 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 7132 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
7133 return result;
7134}
7135
4c4b4cd2
PH
7136/* Scan STR for a subtype-encoded number, beginning at position K.
7137 Put the position of the character just past the number scanned in
7138 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7139 Return 1 if there was a valid number at the given position, and 0
7140 otherwise. A "subtype-encoded" number consists of the absolute value
7141 in decimal, followed by the letter 'm' to indicate a negative number.
7142 Assumes 0m does not occur. */
14f9c5c9
AS
7143
7144int
d2e4a39e 7145ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
7146{
7147 ULONGEST RU;
7148
d2e4a39e 7149 if (!isdigit (str[k]))
14f9c5c9
AS
7150 return 0;
7151
4c4b4cd2 7152 /* Do it the hard way so as not to make any assumption about
14f9c5c9 7153 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 7154 LONGEST. */
14f9c5c9
AS
7155 RU = 0;
7156 while (isdigit (str[k]))
7157 {
d2e4a39e 7158 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
7159 k += 1;
7160 }
7161
d2e4a39e 7162 if (str[k] == 'm')
14f9c5c9
AS
7163 {
7164 if (R != NULL)
4c4b4cd2 7165 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
7166 k += 1;
7167 }
7168 else if (R != NULL)
7169 *R = (LONGEST) RU;
7170
4c4b4cd2 7171 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
7172 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7173 number representable as a LONGEST (although either would probably work
7174 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 7175 above is always equivalent to the negative of RU. */
14f9c5c9
AS
7176
7177 if (new_k != NULL)
7178 *new_k = k;
7179 return 1;
7180}
7181
4c4b4cd2
PH
7182/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7183 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7184 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 7185
d2e4a39e 7186int
ebf56fd3 7187ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 7188{
d2e4a39e 7189 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
7190 int p;
7191
7192 p = 0;
7193 while (1)
7194 {
d2e4a39e 7195 switch (name[p])
4c4b4cd2
PH
7196 {
7197 case '\0':
7198 return 0;
7199 case 'S':
7200 {
7201 LONGEST W;
5b4ee69b 7202
4c4b4cd2
PH
7203 if (!ada_scan_number (name, p + 1, &W, &p))
7204 return 0;
7205 if (val == W)
7206 return 1;
7207 break;
7208 }
7209 case 'R':
7210 {
7211 LONGEST L, U;
5b4ee69b 7212
4c4b4cd2
PH
7213 if (!ada_scan_number (name, p + 1, &L, &p)
7214 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7215 return 0;
7216 if (val >= L && val <= U)
7217 return 1;
7218 break;
7219 }
7220 case 'O':
7221 return 1;
7222 default:
7223 return 0;
7224 }
7225 }
7226}
7227
0963b4bd 7228/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
7229
7230/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7231 ARG_TYPE, extract and return the value of one of its (non-static)
7232 fields. FIELDNO says which field. Differs from value_primitive_field
7233 only in that it can handle packed values of arbitrary type. */
14f9c5c9 7234
4c4b4cd2 7235static struct value *
d2e4a39e 7236ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 7237 struct type *arg_type)
14f9c5c9 7238{
14f9c5c9
AS
7239 struct type *type;
7240
61ee279c 7241 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7242 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7243
4c4b4cd2 7244 /* Handle packed fields. */
14f9c5c9
AS
7245
7246 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7247 {
7248 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7249 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7250
0fd88904 7251 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7252 offset + bit_pos / 8,
7253 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7254 }
7255 else
7256 return value_primitive_field (arg1, offset, fieldno, arg_type);
7257}
7258
52ce6436
PH
7259/* Find field with name NAME in object of type TYPE. If found,
7260 set the following for each argument that is non-null:
7261 - *FIELD_TYPE_P to the field's type;
7262 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7263 an object of that type;
7264 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7265 - *BIT_SIZE_P to its size in bits if the field is packed, and
7266 0 otherwise;
7267 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7268 fields up to but not including the desired field, or by the total
7269 number of fields if not found. A NULL value of NAME never
7270 matches; the function just counts visible fields in this case.
7271
0963b4bd 7272 Returns 1 if found, 0 otherwise. */
52ce6436 7273
4c4b4cd2 7274static int
0d5cff50 7275find_struct_field (const char *name, struct type *type, int offset,
76a01679 7276 struct type **field_type_p,
52ce6436
PH
7277 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7278 int *index_p)
4c4b4cd2
PH
7279{
7280 int i;
7281
61ee279c 7282 type = ada_check_typedef (type);
76a01679 7283
52ce6436
PH
7284 if (field_type_p != NULL)
7285 *field_type_p = NULL;
7286 if (byte_offset_p != NULL)
d5d6fca5 7287 *byte_offset_p = 0;
52ce6436
PH
7288 if (bit_offset_p != NULL)
7289 *bit_offset_p = 0;
7290 if (bit_size_p != NULL)
7291 *bit_size_p = 0;
7292
7293 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7294 {
7295 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7296 int fld_offset = offset + bit_pos / 8;
0d5cff50 7297 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7298
4c4b4cd2
PH
7299 if (t_field_name == NULL)
7300 continue;
7301
52ce6436 7302 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7303 {
7304 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7305
52ce6436
PH
7306 if (field_type_p != NULL)
7307 *field_type_p = TYPE_FIELD_TYPE (type, i);
7308 if (byte_offset_p != NULL)
7309 *byte_offset_p = fld_offset;
7310 if (bit_offset_p != NULL)
7311 *bit_offset_p = bit_pos % 8;
7312 if (bit_size_p != NULL)
7313 *bit_size_p = bit_size;
76a01679
JB
7314 return 1;
7315 }
4c4b4cd2
PH
7316 else if (ada_is_wrapper_field (type, i))
7317 {
52ce6436
PH
7318 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7319 field_type_p, byte_offset_p, bit_offset_p,
7320 bit_size_p, index_p))
76a01679
JB
7321 return 1;
7322 }
4c4b4cd2
PH
7323 else if (ada_is_variant_part (type, i))
7324 {
52ce6436
PH
7325 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7326 fixed type?? */
4c4b4cd2 7327 int j;
52ce6436
PH
7328 struct type *field_type
7329 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7330
52ce6436 7331 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7332 {
76a01679
JB
7333 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7334 fld_offset
7335 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7336 field_type_p, byte_offset_p,
52ce6436 7337 bit_offset_p, bit_size_p, index_p))
76a01679 7338 return 1;
4c4b4cd2
PH
7339 }
7340 }
52ce6436
PH
7341 else if (index_p != NULL)
7342 *index_p += 1;
4c4b4cd2
PH
7343 }
7344 return 0;
7345}
7346
0963b4bd 7347/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7348
52ce6436
PH
7349static int
7350num_visible_fields (struct type *type)
7351{
7352 int n;
5b4ee69b 7353
52ce6436
PH
7354 n = 0;
7355 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7356 return n;
7357}
14f9c5c9 7358
4c4b4cd2 7359/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7360 and search in it assuming it has (class) type TYPE.
7361 If found, return value, else return NULL.
7362
4c4b4cd2 7363 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 7364
4c4b4cd2 7365static struct value *
108d56a4 7366ada_search_struct_field (const char *name, struct value *arg, int offset,
4c4b4cd2 7367 struct type *type)
14f9c5c9
AS
7368{
7369 int i;
14f9c5c9 7370
5b4ee69b 7371 type = ada_check_typedef (type);
52ce6436 7372 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7373 {
0d5cff50 7374 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7375
7376 if (t_field_name == NULL)
4c4b4cd2 7377 continue;
14f9c5c9
AS
7378
7379 else if (field_name_match (t_field_name, name))
4c4b4cd2 7380 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7381
7382 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7383 {
0963b4bd 7384 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7385 ada_search_struct_field (name, arg,
7386 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7387 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7388
4c4b4cd2
PH
7389 if (v != NULL)
7390 return v;
7391 }
14f9c5c9
AS
7392
7393 else if (ada_is_variant_part (type, i))
4c4b4cd2 7394 {
0963b4bd 7395 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7396 int j;
5b4ee69b
MS
7397 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7398 i));
4c4b4cd2
PH
7399 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7400
52ce6436 7401 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7402 {
0963b4bd
MS
7403 struct value *v = ada_search_struct_field /* Force line
7404 break. */
06d5cf63
JB
7405 (name, arg,
7406 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7407 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7408
4c4b4cd2
PH
7409 if (v != NULL)
7410 return v;
7411 }
7412 }
14f9c5c9
AS
7413 }
7414 return NULL;
7415}
d2e4a39e 7416
52ce6436
PH
7417static struct value *ada_index_struct_field_1 (int *, struct value *,
7418 int, struct type *);
7419
7420
7421/* Return field #INDEX in ARG, where the index is that returned by
7422 * find_struct_field through its INDEX_P argument. Adjust the address
7423 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7424 * If found, return value, else return NULL. */
52ce6436
PH
7425
7426static struct value *
7427ada_index_struct_field (int index, struct value *arg, int offset,
7428 struct type *type)
7429{
7430 return ada_index_struct_field_1 (&index, arg, offset, type);
7431}
7432
7433
7434/* Auxiliary function for ada_index_struct_field. Like
7435 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7436 * *INDEX_P. */
52ce6436
PH
7437
7438static struct value *
7439ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7440 struct type *type)
7441{
7442 int i;
7443 type = ada_check_typedef (type);
7444
7445 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7446 {
7447 if (TYPE_FIELD_NAME (type, i) == NULL)
7448 continue;
7449 else if (ada_is_wrapper_field (type, i))
7450 {
0963b4bd 7451 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7452 ada_index_struct_field_1 (index_p, arg,
7453 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7454 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7455
52ce6436
PH
7456 if (v != NULL)
7457 return v;
7458 }
7459
7460 else if (ada_is_variant_part (type, i))
7461 {
7462 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7463 find_struct_field. */
52ce6436
PH
7464 error (_("Cannot assign this kind of variant record"));
7465 }
7466 else if (*index_p == 0)
7467 return ada_value_primitive_field (arg, offset, i, type);
7468 else
7469 *index_p -= 1;
7470 }
7471 return NULL;
7472}
7473
4c4b4cd2
PH
7474/* Given ARG, a value of type (pointer or reference to a)*
7475 structure/union, extract the component named NAME from the ultimate
7476 target structure/union and return it as a value with its
f5938064 7477 appropriate type.
14f9c5c9 7478
4c4b4cd2
PH
7479 The routine searches for NAME among all members of the structure itself
7480 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7481 (e.g., '_parent').
7482
03ee6b2e
PH
7483 If NO_ERR, then simply return NULL in case of error, rather than
7484 calling error. */
14f9c5c9 7485
d2e4a39e 7486struct value *
a121b7c1 7487ada_value_struct_elt (struct value *arg, const char *name, int no_err)
14f9c5c9 7488{
4c4b4cd2 7489 struct type *t, *t1;
d2e4a39e 7490 struct value *v;
14f9c5c9 7491
4c4b4cd2 7492 v = NULL;
df407dfe 7493 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7494 if (TYPE_CODE (t) == TYPE_CODE_REF)
7495 {
7496 t1 = TYPE_TARGET_TYPE (t);
7497 if (t1 == NULL)
03ee6b2e 7498 goto BadValue;
61ee279c 7499 t1 = ada_check_typedef (t1);
4c4b4cd2 7500 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7501 {
994b9211 7502 arg = coerce_ref (arg);
76a01679
JB
7503 t = t1;
7504 }
4c4b4cd2 7505 }
14f9c5c9 7506
4c4b4cd2
PH
7507 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7508 {
7509 t1 = TYPE_TARGET_TYPE (t);
7510 if (t1 == NULL)
03ee6b2e 7511 goto BadValue;
61ee279c 7512 t1 = ada_check_typedef (t1);
4c4b4cd2 7513 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7514 {
7515 arg = value_ind (arg);
7516 t = t1;
7517 }
4c4b4cd2 7518 else
76a01679 7519 break;
4c4b4cd2 7520 }
14f9c5c9 7521
4c4b4cd2 7522 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7523 goto BadValue;
14f9c5c9 7524
4c4b4cd2
PH
7525 if (t1 == t)
7526 v = ada_search_struct_field (name, arg, 0, t);
7527 else
7528 {
7529 int bit_offset, bit_size, byte_offset;
7530 struct type *field_type;
7531 CORE_ADDR address;
7532
76a01679 7533 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7534 address = value_address (ada_value_ind (arg));
4c4b4cd2 7535 else
b50d69b5 7536 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7537
1ed6ede0 7538 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
7539 if (find_struct_field (name, t1, 0,
7540 &field_type, &byte_offset, &bit_offset,
52ce6436 7541 &bit_size, NULL))
76a01679
JB
7542 {
7543 if (bit_size != 0)
7544 {
714e53ab
PH
7545 if (TYPE_CODE (t) == TYPE_CODE_REF)
7546 arg = ada_coerce_ref (arg);
7547 else
7548 arg = ada_value_ind (arg);
76a01679
JB
7549 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7550 bit_offset, bit_size,
7551 field_type);
7552 }
7553 else
f5938064 7554 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7555 }
7556 }
7557
03ee6b2e
PH
7558 if (v != NULL || no_err)
7559 return v;
7560 else
323e0a4a 7561 error (_("There is no member named %s."), name);
14f9c5c9 7562
03ee6b2e
PH
7563 BadValue:
7564 if (no_err)
7565 return NULL;
7566 else
0963b4bd
MS
7567 error (_("Attempt to extract a component of "
7568 "a value that is not a record."));
14f9c5c9
AS
7569}
7570
3b4de39c 7571/* Return a string representation of type TYPE. */
99bbb428 7572
3b4de39c 7573static std::string
99bbb428
PA
7574type_as_string (struct type *type)
7575{
d7e74731 7576 string_file tmp_stream;
99bbb428 7577
d7e74731 7578 type_print (type, "", &tmp_stream, -1);
99bbb428 7579
d7e74731 7580 return std::move (tmp_stream.string ());
99bbb428
PA
7581}
7582
14f9c5c9 7583/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7584 If DISPP is non-null, add its byte displacement from the beginning of a
7585 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7586 work for packed fields).
7587
7588 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7589 followed by "___".
14f9c5c9 7590
0963b4bd 7591 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7592 be a (pointer or reference)+ to a struct or union, and the
7593 ultimate target type will be searched.
14f9c5c9
AS
7594
7595 Looks recursively into variant clauses and parent types.
7596
4c4b4cd2
PH
7597 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7598 TYPE is not a type of the right kind. */
14f9c5c9 7599
4c4b4cd2 7600static struct type *
a121b7c1 7601ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
76a01679 7602 int noerr, int *dispp)
14f9c5c9
AS
7603{
7604 int i;
7605
7606 if (name == NULL)
7607 goto BadName;
7608
76a01679 7609 if (refok && type != NULL)
4c4b4cd2
PH
7610 while (1)
7611 {
61ee279c 7612 type = ada_check_typedef (type);
76a01679
JB
7613 if (TYPE_CODE (type) != TYPE_CODE_PTR
7614 && TYPE_CODE (type) != TYPE_CODE_REF)
7615 break;
7616 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7617 }
14f9c5c9 7618
76a01679 7619 if (type == NULL
1265e4aa
JB
7620 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7621 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7622 {
4c4b4cd2 7623 if (noerr)
76a01679 7624 return NULL;
99bbb428 7625
3b4de39c
PA
7626 error (_("Type %s is not a structure or union type"),
7627 type != NULL ? type_as_string (type).c_str () : _("(null)"));
14f9c5c9
AS
7628 }
7629
7630 type = to_static_fixed_type (type);
7631
7632 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7633 {
0d5cff50 7634 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7635 struct type *t;
7636 int disp;
d2e4a39e 7637
14f9c5c9 7638 if (t_field_name == NULL)
4c4b4cd2 7639 continue;
14f9c5c9
AS
7640
7641 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7642 {
7643 if (dispp != NULL)
7644 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
460efde1 7645 return TYPE_FIELD_TYPE (type, i);
4c4b4cd2 7646 }
14f9c5c9
AS
7647
7648 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7649 {
7650 disp = 0;
7651 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7652 0, 1, &disp);
7653 if (t != NULL)
7654 {
7655 if (dispp != NULL)
7656 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7657 return t;
7658 }
7659 }
14f9c5c9
AS
7660
7661 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7662 {
7663 int j;
5b4ee69b
MS
7664 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7665 i));
4c4b4cd2
PH
7666
7667 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7668 {
b1f33ddd
JB
7669 /* FIXME pnh 2008/01/26: We check for a field that is
7670 NOT wrapped in a struct, since the compiler sometimes
7671 generates these for unchecked variant types. Revisit
0963b4bd 7672 if the compiler changes this practice. */
0d5cff50 7673 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7674 disp = 0;
b1f33ddd
JB
7675 if (v_field_name != NULL
7676 && field_name_match (v_field_name, name))
460efde1 7677 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7678 else
0963b4bd
MS
7679 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7680 j),
b1f33ddd
JB
7681 name, 0, 1, &disp);
7682
4c4b4cd2
PH
7683 if (t != NULL)
7684 {
7685 if (dispp != NULL)
7686 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7687 return t;
7688 }
7689 }
7690 }
14f9c5c9
AS
7691
7692 }
7693
7694BadName:
d2e4a39e 7695 if (!noerr)
14f9c5c9 7696 {
2b2798cc 7697 const char *name_str = name != NULL ? name : _("<null>");
99bbb428
PA
7698
7699 error (_("Type %s has no component named %s"),
3b4de39c 7700 type_as_string (type).c_str (), name_str);
14f9c5c9
AS
7701 }
7702
7703 return NULL;
7704}
7705
b1f33ddd
JB
7706/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7707 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7708 represents an unchecked union (that is, the variant part of a
0963b4bd 7709 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7710
7711static int
7712is_unchecked_variant (struct type *var_type, struct type *outer_type)
7713{
a121b7c1 7714 const char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7715
b1f33ddd
JB
7716 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7717 == NULL);
7718}
7719
7720
14f9c5c9
AS
7721/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7722 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7723 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7724 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7725
d2e4a39e 7726int
ebf56fd3 7727ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7728 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7729{
7730 int others_clause;
7731 int i;
a121b7c1 7732 const char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7733 struct value *outer;
7734 struct value *discrim;
14f9c5c9
AS
7735 LONGEST discrim_val;
7736
012370f6
TT
7737 /* Using plain value_from_contents_and_address here causes problems
7738 because we will end up trying to resolve a type that is currently
7739 being constructed. */
7740 outer = value_from_contents_and_address_unresolved (outer_type,
7741 outer_valaddr, 0);
0c281816
JB
7742 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7743 if (discrim == NULL)
14f9c5c9 7744 return -1;
0c281816 7745 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7746
7747 others_clause = -1;
7748 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7749 {
7750 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7751 others_clause = i;
14f9c5c9 7752 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7753 return i;
14f9c5c9
AS
7754 }
7755
7756 return others_clause;
7757}
d2e4a39e 7758\f
14f9c5c9
AS
7759
7760
4c4b4cd2 7761 /* Dynamic-Sized Records */
14f9c5c9
AS
7762
7763/* Strategy: The type ostensibly attached to a value with dynamic size
7764 (i.e., a size that is not statically recorded in the debugging
7765 data) does not accurately reflect the size or layout of the value.
7766 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7767 conventional types that are constructed on the fly. */
14f9c5c9
AS
7768
7769/* There is a subtle and tricky problem here. In general, we cannot
7770 determine the size of dynamic records without its data. However,
7771 the 'struct value' data structure, which GDB uses to represent
7772 quantities in the inferior process (the target), requires the size
7773 of the type at the time of its allocation in order to reserve space
7774 for GDB's internal copy of the data. That's why the
7775 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7776 rather than struct value*s.
14f9c5c9
AS
7777
7778 However, GDB's internal history variables ($1, $2, etc.) are
7779 struct value*s containing internal copies of the data that are not, in
7780 general, the same as the data at their corresponding addresses in
7781 the target. Fortunately, the types we give to these values are all
7782 conventional, fixed-size types (as per the strategy described
7783 above), so that we don't usually have to perform the
7784 'to_fixed_xxx_type' conversions to look at their values.
7785 Unfortunately, there is one exception: if one of the internal
7786 history variables is an array whose elements are unconstrained
7787 records, then we will need to create distinct fixed types for each
7788 element selected. */
7789
7790/* The upshot of all of this is that many routines take a (type, host
7791 address, target address) triple as arguments to represent a value.
7792 The host address, if non-null, is supposed to contain an internal
7793 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7794 target at the target address. */
14f9c5c9
AS
7795
7796/* Assuming that VAL0 represents a pointer value, the result of
7797 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7798 dynamic-sized types. */
14f9c5c9 7799
d2e4a39e
AS
7800struct value *
7801ada_value_ind (struct value *val0)
14f9c5c9 7802{
c48db5ca 7803 struct value *val = value_ind (val0);
5b4ee69b 7804
b50d69b5
JG
7805 if (ada_is_tagged_type (value_type (val), 0))
7806 val = ada_tag_value_at_base_address (val);
7807
4c4b4cd2 7808 return ada_to_fixed_value (val);
14f9c5c9
AS
7809}
7810
7811/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7812 qualifiers on VAL0. */
7813
d2e4a39e
AS
7814static struct value *
7815ada_coerce_ref (struct value *val0)
7816{
df407dfe 7817 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7818 {
7819 struct value *val = val0;
5b4ee69b 7820
994b9211 7821 val = coerce_ref (val);
b50d69b5
JG
7822
7823 if (ada_is_tagged_type (value_type (val), 0))
7824 val = ada_tag_value_at_base_address (val);
7825
4c4b4cd2 7826 return ada_to_fixed_value (val);
d2e4a39e
AS
7827 }
7828 else
14f9c5c9
AS
7829 return val0;
7830}
7831
7832/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7833 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7834
7835static unsigned int
ebf56fd3 7836align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7837{
7838 return (off + alignment - 1) & ~(alignment - 1);
7839}
7840
4c4b4cd2 7841/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7842
7843static unsigned int
ebf56fd3 7844field_alignment (struct type *type, int f)
14f9c5c9 7845{
d2e4a39e 7846 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7847 int len;
14f9c5c9
AS
7848 int align_offset;
7849
64a1bf19
JB
7850 /* The field name should never be null, unless the debugging information
7851 is somehow malformed. In this case, we assume the field does not
7852 require any alignment. */
7853 if (name == NULL)
7854 return 1;
7855
7856 len = strlen (name);
7857
4c4b4cd2
PH
7858 if (!isdigit (name[len - 1]))
7859 return 1;
14f9c5c9 7860
d2e4a39e 7861 if (isdigit (name[len - 2]))
14f9c5c9
AS
7862 align_offset = len - 2;
7863 else
7864 align_offset = len - 1;
7865
61012eef 7866 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7867 return TARGET_CHAR_BIT;
7868
4c4b4cd2
PH
7869 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7870}
7871
852dff6c 7872/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7873
852dff6c
JB
7874static struct symbol *
7875ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7876{
7877 struct symbol *sym;
7878
7879 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7880 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7881 return sym;
7882
4186eb54
KS
7883 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7884 return sym;
14f9c5c9
AS
7885}
7886
dddfab26
UW
7887/* Find a type named NAME. Ignores ambiguity. This routine will look
7888 solely for types defined by debug info, it will not search the GDB
7889 primitive types. */
4c4b4cd2 7890
852dff6c 7891static struct type *
ebf56fd3 7892ada_find_any_type (const char *name)
14f9c5c9 7893{
852dff6c 7894 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7895
14f9c5c9 7896 if (sym != NULL)
dddfab26 7897 return SYMBOL_TYPE (sym);
14f9c5c9 7898
dddfab26 7899 return NULL;
14f9c5c9
AS
7900}
7901
739593e0
JB
7902/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7903 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7904 symbol, in which case it is returned. Otherwise, this looks for
7905 symbols whose name is that of NAME_SYM suffixed with "___XR".
7906 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7907
7908struct symbol *
270140bd 7909ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7910{
739593e0 7911 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7912 struct symbol *sym;
7913
739593e0
JB
7914 if (strstr (name, "___XR") != NULL)
7915 return name_sym;
7916
aeb5907d
JB
7917 sym = find_old_style_renaming_symbol (name, block);
7918
7919 if (sym != NULL)
7920 return sym;
7921
0963b4bd 7922 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7923 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7924 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7925 return sym;
7926 else
7927 return NULL;
7928}
7929
7930static struct symbol *
270140bd 7931find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7932{
7f0df278 7933 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7934 char *rename;
7935
7936 if (function_sym != NULL)
7937 {
7938 /* If the symbol is defined inside a function, NAME is not fully
7939 qualified. This means we need to prepend the function name
7940 as well as adding the ``___XR'' suffix to build the name of
7941 the associated renaming symbol. */
0d5cff50 7942 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7943 /* Function names sometimes contain suffixes used
7944 for instance to qualify nested subprograms. When building
7945 the XR type name, we need to make sure that this suffix is
7946 not included. So do not include any suffix in the function
7947 name length below. */
69fadcdf 7948 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7949 const int rename_len = function_name_len + 2 /* "__" */
7950 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7951
529cad9c 7952 /* Strip the suffix if necessary. */
69fadcdf
JB
7953 ada_remove_trailing_digits (function_name, &function_name_len);
7954 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7955 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7956
4c4b4cd2
PH
7957 /* Library-level functions are a special case, as GNAT adds
7958 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7959 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7960 have this prefix, so we need to skip this prefix if present. */
7961 if (function_name_len > 5 /* "_ada_" */
7962 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7963 {
7964 function_name += 5;
7965 function_name_len -= 5;
7966 }
4c4b4cd2
PH
7967
7968 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7969 strncpy (rename, function_name, function_name_len);
7970 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7971 "__%s___XR", name);
4c4b4cd2
PH
7972 }
7973 else
7974 {
7975 const int rename_len = strlen (name) + 6;
5b4ee69b 7976
4c4b4cd2 7977 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7978 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7979 }
7980
852dff6c 7981 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7982}
7983
14f9c5c9 7984/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7985 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7986 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7987 otherwise return 0. */
7988
14f9c5c9 7989int
d2e4a39e 7990ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7991{
7992 if (type1 == NULL)
7993 return 1;
7994 else if (type0 == NULL)
7995 return 0;
7996 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7997 return 1;
7998 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7999 return 0;
4c4b4cd2
PH
8000 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8001 return 1;
ad82864c 8002 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 8003 return 1;
4c4b4cd2
PH
8004 else if (ada_is_array_descriptor_type (type0)
8005 && !ada_is_array_descriptor_type (type1))
14f9c5c9 8006 return 1;
aeb5907d
JB
8007 else
8008 {
8009 const char *type0_name = type_name_no_tag (type0);
8010 const char *type1_name = type_name_no_tag (type1);
8011
8012 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8013 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8014 return 1;
8015 }
14f9c5c9
AS
8016 return 0;
8017}
8018
8019/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
8020 null, its TYPE_TAG_NAME. Null if TYPE is null. */
8021
0d5cff50 8022const char *
d2e4a39e 8023ada_type_name (struct type *type)
14f9c5c9 8024{
d2e4a39e 8025 if (type == NULL)
14f9c5c9
AS
8026 return NULL;
8027 else if (TYPE_NAME (type) != NULL)
8028 return TYPE_NAME (type);
8029 else
8030 return TYPE_TAG_NAME (type);
8031}
8032
b4ba55a1
JB
8033/* Search the list of "descriptive" types associated to TYPE for a type
8034 whose name is NAME. */
8035
8036static struct type *
8037find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8038{
931e5bc3 8039 struct type *result, *tmp;
b4ba55a1 8040
c6044dd1
JB
8041 if (ada_ignore_descriptive_types_p)
8042 return NULL;
8043
b4ba55a1
JB
8044 /* If there no descriptive-type info, then there is no parallel type
8045 to be found. */
8046 if (!HAVE_GNAT_AUX_INFO (type))
8047 return NULL;
8048
8049 result = TYPE_DESCRIPTIVE_TYPE (type);
8050 while (result != NULL)
8051 {
0d5cff50 8052 const char *result_name = ada_type_name (result);
b4ba55a1
JB
8053
8054 if (result_name == NULL)
8055 {
8056 warning (_("unexpected null name on descriptive type"));
8057 return NULL;
8058 }
8059
8060 /* If the names match, stop. */
8061 if (strcmp (result_name, name) == 0)
8062 break;
8063
8064 /* Otherwise, look at the next item on the list, if any. */
8065 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
8066 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8067 else
8068 tmp = NULL;
8069
8070 /* If not found either, try after having resolved the typedef. */
8071 if (tmp != NULL)
8072 result = tmp;
b4ba55a1 8073 else
931e5bc3 8074 {
f168693b 8075 result = check_typedef (result);
931e5bc3
JG
8076 if (HAVE_GNAT_AUX_INFO (result))
8077 result = TYPE_DESCRIPTIVE_TYPE (result);
8078 else
8079 result = NULL;
8080 }
b4ba55a1
JB
8081 }
8082
8083 /* If we didn't find a match, see whether this is a packed array. With
8084 older compilers, the descriptive type information is either absent or
8085 irrelevant when it comes to packed arrays so the above lookup fails.
8086 Fall back to using a parallel lookup by name in this case. */
12ab9e09 8087 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
8088 return ada_find_any_type (name);
8089
8090 return result;
8091}
8092
8093/* Find a parallel type to TYPE with the specified NAME, using the
8094 descriptive type taken from the debugging information, if available,
8095 and otherwise using the (slower) name-based method. */
8096
8097static struct type *
8098ada_find_parallel_type_with_name (struct type *type, const char *name)
8099{
8100 struct type *result = NULL;
8101
8102 if (HAVE_GNAT_AUX_INFO (type))
8103 result = find_parallel_type_by_descriptive_type (type, name);
8104 else
8105 result = ada_find_any_type (name);
8106
8107 return result;
8108}
8109
8110/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 8111 SUFFIX to the name of TYPE. */
14f9c5c9 8112
d2e4a39e 8113struct type *
ebf56fd3 8114ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 8115{
0d5cff50 8116 char *name;
fe978cb0 8117 const char *type_name = ada_type_name (type);
14f9c5c9 8118 int len;
d2e4a39e 8119
fe978cb0 8120 if (type_name == NULL)
14f9c5c9
AS
8121 return NULL;
8122
fe978cb0 8123 len = strlen (type_name);
14f9c5c9 8124
b4ba55a1 8125 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 8126
fe978cb0 8127 strcpy (name, type_name);
14f9c5c9
AS
8128 strcpy (name + len, suffix);
8129
b4ba55a1 8130 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
8131}
8132
14f9c5c9 8133/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 8134 type describing its fields. Otherwise, return NULL. */
14f9c5c9 8135
d2e4a39e
AS
8136static struct type *
8137dynamic_template_type (struct type *type)
14f9c5c9 8138{
61ee279c 8139 type = ada_check_typedef (type);
14f9c5c9
AS
8140
8141 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 8142 || ada_type_name (type) == NULL)
14f9c5c9 8143 return NULL;
d2e4a39e 8144 else
14f9c5c9
AS
8145 {
8146 int len = strlen (ada_type_name (type));
5b4ee69b 8147
4c4b4cd2
PH
8148 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8149 return type;
14f9c5c9 8150 else
4c4b4cd2 8151 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
8152 }
8153}
8154
8155/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 8156 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 8157
d2e4a39e
AS
8158static int
8159is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
8160{
8161 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 8162
d2e4a39e 8163 return name != NULL
14f9c5c9
AS
8164 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8165 && strstr (name, "___XVL") != NULL;
8166}
8167
4c4b4cd2
PH
8168/* The index of the variant field of TYPE, or -1 if TYPE does not
8169 represent a variant record type. */
14f9c5c9 8170
d2e4a39e 8171static int
4c4b4cd2 8172variant_field_index (struct type *type)
14f9c5c9
AS
8173{
8174 int f;
8175
4c4b4cd2
PH
8176 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8177 return -1;
8178
8179 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8180 {
8181 if (ada_is_variant_part (type, f))
8182 return f;
8183 }
8184 return -1;
14f9c5c9
AS
8185}
8186
4c4b4cd2
PH
8187/* A record type with no fields. */
8188
d2e4a39e 8189static struct type *
fe978cb0 8190empty_record (struct type *templ)
14f9c5c9 8191{
fe978cb0 8192 struct type *type = alloc_type_copy (templ);
5b4ee69b 8193
14f9c5c9
AS
8194 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8195 TYPE_NFIELDS (type) = 0;
8196 TYPE_FIELDS (type) = NULL;
b1f33ddd 8197 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
8198 TYPE_NAME (type) = "<empty>";
8199 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
8200 TYPE_LENGTH (type) = 0;
8201 return type;
8202}
8203
8204/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
8205 the value of type TYPE at VALADDR or ADDRESS (see comments at
8206 the beginning of this section) VAL according to GNAT conventions.
8207 DVAL0 should describe the (portion of a) record that contains any
df407dfe 8208 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
8209 an outer-level type (i.e., as opposed to a branch of a variant.) A
8210 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 8211 of the variant.
14f9c5c9 8212
4c4b4cd2
PH
8213 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8214 length are not statically known are discarded. As a consequence,
8215 VALADDR, ADDRESS and DVAL0 are ignored.
8216
8217 NOTE: Limitations: For now, we assume that dynamic fields and
8218 variants occupy whole numbers of bytes. However, they need not be
8219 byte-aligned. */
8220
8221struct type *
10a2c479 8222ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 8223 const gdb_byte *valaddr,
4c4b4cd2
PH
8224 CORE_ADDR address, struct value *dval0,
8225 int keep_dynamic_fields)
14f9c5c9 8226{
d2e4a39e
AS
8227 struct value *mark = value_mark ();
8228 struct value *dval;
8229 struct type *rtype;
14f9c5c9 8230 int nfields, bit_len;
4c4b4cd2 8231 int variant_field;
14f9c5c9 8232 long off;
d94e4f4f 8233 int fld_bit_len;
14f9c5c9
AS
8234 int f;
8235
4c4b4cd2
PH
8236 /* Compute the number of fields in this record type that are going
8237 to be processed: unless keep_dynamic_fields, this includes only
8238 fields whose position and length are static will be processed. */
8239 if (keep_dynamic_fields)
8240 nfields = TYPE_NFIELDS (type);
8241 else
8242 {
8243 nfields = 0;
76a01679 8244 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8245 && !ada_is_variant_part (type, nfields)
8246 && !is_dynamic_field (type, nfields))
8247 nfields++;
8248 }
8249
e9bb382b 8250 rtype = alloc_type_copy (type);
14f9c5c9
AS
8251 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8252 INIT_CPLUS_SPECIFIC (rtype);
8253 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8254 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8255 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8256 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8257 TYPE_NAME (rtype) = ada_type_name (type);
8258 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8259 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8260
d2e4a39e
AS
8261 off = 0;
8262 bit_len = 0;
4c4b4cd2
PH
8263 variant_field = -1;
8264
14f9c5c9
AS
8265 for (f = 0; f < nfields; f += 1)
8266 {
6c038f32
PH
8267 off = align_value (off, field_alignment (type, f))
8268 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8269 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8270 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8271
d2e4a39e 8272 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8273 {
8274 variant_field = f;
d94e4f4f 8275 fld_bit_len = 0;
4c4b4cd2 8276 }
14f9c5c9 8277 else if (is_dynamic_field (type, f))
4c4b4cd2 8278 {
284614f0
JB
8279 const gdb_byte *field_valaddr = valaddr;
8280 CORE_ADDR field_address = address;
8281 struct type *field_type =
8282 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8283
4c4b4cd2 8284 if (dval0 == NULL)
b5304971
JG
8285 {
8286 /* rtype's length is computed based on the run-time
8287 value of discriminants. If the discriminants are not
8288 initialized, the type size may be completely bogus and
0963b4bd 8289 GDB may fail to allocate a value for it. So check the
b5304971 8290 size first before creating the value. */
c1b5a1a6 8291 ada_ensure_varsize_limit (rtype);
012370f6
TT
8292 /* Using plain value_from_contents_and_address here
8293 causes problems because we will end up trying to
8294 resolve a type that is currently being
8295 constructed. */
8296 dval = value_from_contents_and_address_unresolved (rtype,
8297 valaddr,
8298 address);
9f1f738a 8299 rtype = value_type (dval);
b5304971 8300 }
4c4b4cd2
PH
8301 else
8302 dval = dval0;
8303
284614f0
JB
8304 /* If the type referenced by this field is an aligner type, we need
8305 to unwrap that aligner type, because its size might not be set.
8306 Keeping the aligner type would cause us to compute the wrong
8307 size for this field, impacting the offset of the all the fields
8308 that follow this one. */
8309 if (ada_is_aligner_type (field_type))
8310 {
8311 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8312
8313 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8314 field_address = cond_offset_target (field_address, field_offset);
8315 field_type = ada_aligned_type (field_type);
8316 }
8317
8318 field_valaddr = cond_offset_host (field_valaddr,
8319 off / TARGET_CHAR_BIT);
8320 field_address = cond_offset_target (field_address,
8321 off / TARGET_CHAR_BIT);
8322
8323 /* Get the fixed type of the field. Note that, in this case,
8324 we do not want to get the real type out of the tag: if
8325 the current field is the parent part of a tagged record,
8326 we will get the tag of the object. Clearly wrong: the real
8327 type of the parent is not the real type of the child. We
8328 would end up in an infinite loop. */
8329 field_type = ada_get_base_type (field_type);
8330 field_type = ada_to_fixed_type (field_type, field_valaddr,
8331 field_address, dval, 0);
27f2a97b
JB
8332 /* If the field size is already larger than the maximum
8333 object size, then the record itself will necessarily
8334 be larger than the maximum object size. We need to make
8335 this check now, because the size might be so ridiculously
8336 large (due to an uninitialized variable in the inferior)
8337 that it would cause an overflow when adding it to the
8338 record size. */
c1b5a1a6 8339 ada_ensure_varsize_limit (field_type);
284614f0
JB
8340
8341 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8342 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8343 /* The multiplication can potentially overflow. But because
8344 the field length has been size-checked just above, and
8345 assuming that the maximum size is a reasonable value,
8346 an overflow should not happen in practice. So rather than
8347 adding overflow recovery code to this already complex code,
8348 we just assume that it's not going to happen. */
d94e4f4f 8349 fld_bit_len =
4c4b4cd2
PH
8350 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8351 }
14f9c5c9 8352 else
4c4b4cd2 8353 {
5ded5331
JB
8354 /* Note: If this field's type is a typedef, it is important
8355 to preserve the typedef layer.
8356
8357 Otherwise, we might be transforming a typedef to a fat
8358 pointer (encoding a pointer to an unconstrained array),
8359 into a basic fat pointer (encoding an unconstrained
8360 array). As both types are implemented using the same
8361 structure, the typedef is the only clue which allows us
8362 to distinguish between the two options. Stripping it
8363 would prevent us from printing this field appropriately. */
8364 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8365 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8366 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8367 fld_bit_len =
4c4b4cd2
PH
8368 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8369 else
5ded5331
JB
8370 {
8371 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8372
8373 /* We need to be careful of typedefs when computing
8374 the length of our field. If this is a typedef,
8375 get the length of the target type, not the length
8376 of the typedef. */
8377 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8378 field_type = ada_typedef_target_type (field_type);
8379
8380 fld_bit_len =
8381 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8382 }
4c4b4cd2 8383 }
14f9c5c9 8384 if (off + fld_bit_len > bit_len)
4c4b4cd2 8385 bit_len = off + fld_bit_len;
d94e4f4f 8386 off += fld_bit_len;
4c4b4cd2
PH
8387 TYPE_LENGTH (rtype) =
8388 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8389 }
4c4b4cd2
PH
8390
8391 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8392 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8393 the record. This can happen in the presence of representation
8394 clauses. */
8395 if (variant_field >= 0)
8396 {
8397 struct type *branch_type;
8398
8399 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8400
8401 if (dval0 == NULL)
9f1f738a 8402 {
012370f6
TT
8403 /* Using plain value_from_contents_and_address here causes
8404 problems because we will end up trying to resolve a type
8405 that is currently being constructed. */
8406 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8407 address);
9f1f738a
SA
8408 rtype = value_type (dval);
8409 }
4c4b4cd2
PH
8410 else
8411 dval = dval0;
8412
8413 branch_type =
8414 to_fixed_variant_branch_type
8415 (TYPE_FIELD_TYPE (type, variant_field),
8416 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8417 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8418 if (branch_type == NULL)
8419 {
8420 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8421 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8422 TYPE_NFIELDS (rtype) -= 1;
8423 }
8424 else
8425 {
8426 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8427 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8428 fld_bit_len =
8429 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8430 TARGET_CHAR_BIT;
8431 if (off + fld_bit_len > bit_len)
8432 bit_len = off + fld_bit_len;
8433 TYPE_LENGTH (rtype) =
8434 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8435 }
8436 }
8437
714e53ab
PH
8438 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8439 should contain the alignment of that record, which should be a strictly
8440 positive value. If null or negative, then something is wrong, most
8441 probably in the debug info. In that case, we don't round up the size
0963b4bd 8442 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8443 the current RTYPE length might be good enough for our purposes. */
8444 if (TYPE_LENGTH (type) <= 0)
8445 {
323e0a4a
AC
8446 if (TYPE_NAME (rtype))
8447 warning (_("Invalid type size for `%s' detected: %d."),
8448 TYPE_NAME (rtype), TYPE_LENGTH (type));
8449 else
8450 warning (_("Invalid type size for <unnamed> detected: %d."),
8451 TYPE_LENGTH (type));
714e53ab
PH
8452 }
8453 else
8454 {
8455 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8456 TYPE_LENGTH (type));
8457 }
14f9c5c9
AS
8458
8459 value_free_to_mark (mark);
d2e4a39e 8460 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8461 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8462 return rtype;
8463}
8464
4c4b4cd2
PH
8465/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8466 of 1. */
14f9c5c9 8467
d2e4a39e 8468static struct type *
fc1a4b47 8469template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8470 CORE_ADDR address, struct value *dval0)
8471{
8472 return ada_template_to_fixed_record_type_1 (type, valaddr,
8473 address, dval0, 1);
8474}
8475
8476/* An ordinary record type in which ___XVL-convention fields and
8477 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8478 static approximations, containing all possible fields. Uses
8479 no runtime values. Useless for use in values, but that's OK,
8480 since the results are used only for type determinations. Works on both
8481 structs and unions. Representation note: to save space, we memorize
8482 the result of this function in the TYPE_TARGET_TYPE of the
8483 template type. */
8484
8485static struct type *
8486template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8487{
8488 struct type *type;
8489 int nfields;
8490 int f;
8491
9e195661
PMR
8492 /* No need no do anything if the input type is already fixed. */
8493 if (TYPE_FIXED_INSTANCE (type0))
8494 return type0;
8495
8496 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8497 if (TYPE_TARGET_TYPE (type0) != NULL)
8498 return TYPE_TARGET_TYPE (type0);
8499
9e195661 8500 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8501 type = type0;
9e195661
PMR
8502 nfields = TYPE_NFIELDS (type0);
8503
8504 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8505 recompute all over next time. */
8506 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8507
8508 for (f = 0; f < nfields; f += 1)
8509 {
460efde1 8510 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8511 struct type *new_type;
14f9c5c9 8512
4c4b4cd2 8513 if (is_dynamic_field (type0, f))
460efde1
JB
8514 {
8515 field_type = ada_check_typedef (field_type);
8516 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8517 }
14f9c5c9 8518 else
f192137b 8519 new_type = static_unwrap_type (field_type);
9e195661
PMR
8520
8521 if (new_type != field_type)
8522 {
8523 /* Clone TYPE0 only the first time we get a new field type. */
8524 if (type == type0)
8525 {
8526 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8527 TYPE_CODE (type) = TYPE_CODE (type0);
8528 INIT_CPLUS_SPECIFIC (type);
8529 TYPE_NFIELDS (type) = nfields;
8530 TYPE_FIELDS (type) = (struct field *)
8531 TYPE_ALLOC (type, nfields * sizeof (struct field));
8532 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8533 sizeof (struct field) * nfields);
8534 TYPE_NAME (type) = ada_type_name (type0);
8535 TYPE_TAG_NAME (type) = NULL;
8536 TYPE_FIXED_INSTANCE (type) = 1;
8537 TYPE_LENGTH (type) = 0;
8538 }
8539 TYPE_FIELD_TYPE (type, f) = new_type;
8540 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8541 }
14f9c5c9 8542 }
9e195661 8543
14f9c5c9
AS
8544 return type;
8545}
8546
4c4b4cd2 8547/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8548 whose address in memory is ADDRESS, returns a revision of TYPE,
8549 which should be a non-dynamic-sized record, in which the variant
8550 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8551 for discriminant values in DVAL0, which can be NULL if the record
8552 contains the necessary discriminant values. */
8553
d2e4a39e 8554static struct type *
fc1a4b47 8555to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8556 CORE_ADDR address, struct value *dval0)
14f9c5c9 8557{
d2e4a39e 8558 struct value *mark = value_mark ();
4c4b4cd2 8559 struct value *dval;
d2e4a39e 8560 struct type *rtype;
14f9c5c9
AS
8561 struct type *branch_type;
8562 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8563 int variant_field = variant_field_index (type);
14f9c5c9 8564
4c4b4cd2 8565 if (variant_field == -1)
14f9c5c9
AS
8566 return type;
8567
4c4b4cd2 8568 if (dval0 == NULL)
9f1f738a
SA
8569 {
8570 dval = value_from_contents_and_address (type, valaddr, address);
8571 type = value_type (dval);
8572 }
4c4b4cd2
PH
8573 else
8574 dval = dval0;
8575
e9bb382b 8576 rtype = alloc_type_copy (type);
14f9c5c9 8577 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8578 INIT_CPLUS_SPECIFIC (rtype);
8579 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8580 TYPE_FIELDS (rtype) =
8581 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8582 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8583 sizeof (struct field) * nfields);
14f9c5c9
AS
8584 TYPE_NAME (rtype) = ada_type_name (type);
8585 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8586 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8587 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8588
4c4b4cd2
PH
8589 branch_type = to_fixed_variant_branch_type
8590 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8591 cond_offset_host (valaddr,
4c4b4cd2
PH
8592 TYPE_FIELD_BITPOS (type, variant_field)
8593 / TARGET_CHAR_BIT),
d2e4a39e 8594 cond_offset_target (address,
4c4b4cd2
PH
8595 TYPE_FIELD_BITPOS (type, variant_field)
8596 / TARGET_CHAR_BIT), dval);
d2e4a39e 8597 if (branch_type == NULL)
14f9c5c9 8598 {
4c4b4cd2 8599 int f;
5b4ee69b 8600
4c4b4cd2
PH
8601 for (f = variant_field + 1; f < nfields; f += 1)
8602 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8603 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8604 }
8605 else
8606 {
4c4b4cd2
PH
8607 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8608 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8609 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8610 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8611 }
4c4b4cd2 8612 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8613
4c4b4cd2 8614 value_free_to_mark (mark);
14f9c5c9
AS
8615 return rtype;
8616}
8617
8618/* An ordinary record type (with fixed-length fields) that describes
8619 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8620 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8621 should be in DVAL, a record value; it may be NULL if the object
8622 at ADDR itself contains any necessary discriminant values.
8623 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8624 values from the record are needed. Except in the case that DVAL,
8625 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8626 unchecked) is replaced by a particular branch of the variant.
8627
8628 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8629 is questionable and may be removed. It can arise during the
8630 processing of an unconstrained-array-of-record type where all the
8631 variant branches have exactly the same size. This is because in
8632 such cases, the compiler does not bother to use the XVS convention
8633 when encoding the record. I am currently dubious of this
8634 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8635
d2e4a39e 8636static struct type *
fc1a4b47 8637to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8638 CORE_ADDR address, struct value *dval)
14f9c5c9 8639{
d2e4a39e 8640 struct type *templ_type;
14f9c5c9 8641
876cecd0 8642 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8643 return type0;
8644
d2e4a39e 8645 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8646
8647 if (templ_type != NULL)
8648 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8649 else if (variant_field_index (type0) >= 0)
8650 {
8651 if (dval == NULL && valaddr == NULL && address == 0)
8652 return type0;
8653 return to_record_with_fixed_variant_part (type0, valaddr, address,
8654 dval);
8655 }
14f9c5c9
AS
8656 else
8657 {
876cecd0 8658 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8659 return type0;
8660 }
8661
8662}
8663
8664/* An ordinary record type (with fixed-length fields) that describes
8665 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8666 union type. Any necessary discriminants' values should be in DVAL,
8667 a record value. That is, this routine selects the appropriate
8668 branch of the union at ADDR according to the discriminant value
b1f33ddd 8669 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8670 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8671
d2e4a39e 8672static struct type *
fc1a4b47 8673to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8674 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8675{
8676 int which;
d2e4a39e
AS
8677 struct type *templ_type;
8678 struct type *var_type;
14f9c5c9
AS
8679
8680 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8681 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8682 else
14f9c5c9
AS
8683 var_type = var_type0;
8684
8685 templ_type = ada_find_parallel_type (var_type, "___XVU");
8686
8687 if (templ_type != NULL)
8688 var_type = templ_type;
8689
b1f33ddd
JB
8690 if (is_unchecked_variant (var_type, value_type (dval)))
8691 return var_type0;
d2e4a39e
AS
8692 which =
8693 ada_which_variant_applies (var_type,
0fd88904 8694 value_type (dval), value_contents (dval));
14f9c5c9
AS
8695
8696 if (which < 0)
e9bb382b 8697 return empty_record (var_type);
14f9c5c9 8698 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8699 return to_fixed_record_type
d2e4a39e
AS
8700 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8701 valaddr, address, dval);
4c4b4cd2 8702 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8703 return
8704 to_fixed_record_type
8705 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8706 else
8707 return TYPE_FIELD_TYPE (var_type, which);
8708}
8709
8908fca5
JB
8710/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8711 ENCODING_TYPE, a type following the GNAT conventions for discrete
8712 type encodings, only carries redundant information. */
8713
8714static int
8715ada_is_redundant_range_encoding (struct type *range_type,
8716 struct type *encoding_type)
8717{
8718 struct type *fixed_range_type;
108d56a4 8719 const char *bounds_str;
8908fca5
JB
8720 int n;
8721 LONGEST lo, hi;
8722
8723 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8724
005e2509
JB
8725 if (TYPE_CODE (get_base_type (range_type))
8726 != TYPE_CODE (get_base_type (encoding_type)))
8727 {
8728 /* The compiler probably used a simple base type to describe
8729 the range type instead of the range's actual base type,
8730 expecting us to get the real base type from the encoding
8731 anyway. In this situation, the encoding cannot be ignored
8732 as redundant. */
8733 return 0;
8734 }
8735
8908fca5
JB
8736 if (is_dynamic_type (range_type))
8737 return 0;
8738
8739 if (TYPE_NAME (encoding_type) == NULL)
8740 return 0;
8741
8742 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8743 if (bounds_str == NULL)
8744 return 0;
8745
8746 n = 8; /* Skip "___XDLU_". */
8747 if (!ada_scan_number (bounds_str, n, &lo, &n))
8748 return 0;
8749 if (TYPE_LOW_BOUND (range_type) != lo)
8750 return 0;
8751
8752 n += 2; /* Skip the "__" separator between the two bounds. */
8753 if (!ada_scan_number (bounds_str, n, &hi, &n))
8754 return 0;
8755 if (TYPE_HIGH_BOUND (range_type) != hi)
8756 return 0;
8757
8758 return 1;
8759}
8760
8761/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8762 a type following the GNAT encoding for describing array type
8763 indices, only carries redundant information. */
8764
8765static int
8766ada_is_redundant_index_type_desc (struct type *array_type,
8767 struct type *desc_type)
8768{
8769 struct type *this_layer = check_typedef (array_type);
8770 int i;
8771
8772 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8773 {
8774 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8775 TYPE_FIELD_TYPE (desc_type, i)))
8776 return 0;
8777 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8778 }
8779
8780 return 1;
8781}
8782
14f9c5c9
AS
8783/* Assuming that TYPE0 is an array type describing the type of a value
8784 at ADDR, and that DVAL describes a record containing any
8785 discriminants used in TYPE0, returns a type for the value that
8786 contains no dynamic components (that is, no components whose sizes
8787 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8788 true, gives an error message if the resulting type's size is over
4c4b4cd2 8789 varsize_limit. */
14f9c5c9 8790
d2e4a39e
AS
8791static struct type *
8792to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8793 int ignore_too_big)
14f9c5c9 8794{
d2e4a39e
AS
8795 struct type *index_type_desc;
8796 struct type *result;
ad82864c 8797 int constrained_packed_array_p;
931e5bc3 8798 static const char *xa_suffix = "___XA";
14f9c5c9 8799
b0dd7688 8800 type0 = ada_check_typedef (type0);
284614f0 8801 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8802 return type0;
14f9c5c9 8803
ad82864c
JB
8804 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8805 if (constrained_packed_array_p)
8806 type0 = decode_constrained_packed_array_type (type0);
284614f0 8807
931e5bc3
JG
8808 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8809
8810 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8811 encoding suffixed with 'P' may still be generated. If so,
8812 it should be used to find the XA type. */
8813
8814 if (index_type_desc == NULL)
8815 {
1da0522e 8816 const char *type_name = ada_type_name (type0);
931e5bc3 8817
1da0522e 8818 if (type_name != NULL)
931e5bc3 8819 {
1da0522e 8820 const int len = strlen (type_name);
931e5bc3
JG
8821 char *name = (char *) alloca (len + strlen (xa_suffix));
8822
1da0522e 8823 if (type_name[len - 1] == 'P')
931e5bc3 8824 {
1da0522e 8825 strcpy (name, type_name);
931e5bc3
JG
8826 strcpy (name + len - 1, xa_suffix);
8827 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8828 }
8829 }
8830 }
8831
28c85d6c 8832 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8833 if (index_type_desc != NULL
8834 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8835 {
8836 /* Ignore this ___XA parallel type, as it does not bring any
8837 useful information. This allows us to avoid creating fixed
8838 versions of the array's index types, which would be identical
8839 to the original ones. This, in turn, can also help avoid
8840 the creation of fixed versions of the array itself. */
8841 index_type_desc = NULL;
8842 }
8843
14f9c5c9
AS
8844 if (index_type_desc == NULL)
8845 {
61ee279c 8846 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8847
14f9c5c9 8848 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8849 depend on the contents of the array in properly constructed
8850 debugging data. */
529cad9c
PH
8851 /* Create a fixed version of the array element type.
8852 We're not providing the address of an element here,
e1d5a0d2 8853 and thus the actual object value cannot be inspected to do
529cad9c
PH
8854 the conversion. This should not be a problem, since arrays of
8855 unconstrained objects are not allowed. In particular, all
8856 the elements of an array of a tagged type should all be of
8857 the same type specified in the debugging info. No need to
8858 consult the object tag. */
1ed6ede0 8859 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8860
284614f0
JB
8861 /* Make sure we always create a new array type when dealing with
8862 packed array types, since we're going to fix-up the array
8863 type length and element bitsize a little further down. */
ad82864c 8864 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8865 result = type0;
14f9c5c9 8866 else
e9bb382b 8867 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8868 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8869 }
8870 else
8871 {
8872 int i;
8873 struct type *elt_type0;
8874
8875 elt_type0 = type0;
8876 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8877 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8878
8879 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8880 depend on the contents of the array in properly constructed
8881 debugging data. */
529cad9c
PH
8882 /* Create a fixed version of the array element type.
8883 We're not providing the address of an element here,
e1d5a0d2 8884 and thus the actual object value cannot be inspected to do
529cad9c
PH
8885 the conversion. This should not be a problem, since arrays of
8886 unconstrained objects are not allowed. In particular, all
8887 the elements of an array of a tagged type should all be of
8888 the same type specified in the debugging info. No need to
8889 consult the object tag. */
1ed6ede0
JB
8890 result =
8891 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8892
8893 elt_type0 = type0;
14f9c5c9 8894 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8895 {
8896 struct type *range_type =
28c85d6c 8897 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8898
e9bb382b 8899 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8900 result, range_type);
1ce677a4 8901 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8902 }
d2e4a39e 8903 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8904 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8905 }
8906
2e6fda7d
JB
8907 /* We want to preserve the type name. This can be useful when
8908 trying to get the type name of a value that has already been
8909 printed (for instance, if the user did "print VAR; whatis $". */
8910 TYPE_NAME (result) = TYPE_NAME (type0);
8911
ad82864c 8912 if (constrained_packed_array_p)
284614f0
JB
8913 {
8914 /* So far, the resulting type has been created as if the original
8915 type was a regular (non-packed) array type. As a result, the
8916 bitsize of the array elements needs to be set again, and the array
8917 length needs to be recomputed based on that bitsize. */
8918 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8919 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8920
8921 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8922 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8923 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8924 TYPE_LENGTH (result)++;
8925 }
8926
876cecd0 8927 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8928 return result;
d2e4a39e 8929}
14f9c5c9
AS
8930
8931
8932/* A standard type (containing no dynamically sized components)
8933 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8934 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8935 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8936 ADDRESS or in VALADDR contains these discriminants.
8937
1ed6ede0
JB
8938 If CHECK_TAG is not null, in the case of tagged types, this function
8939 attempts to locate the object's tag and use it to compute the actual
8940 type. However, when ADDRESS is null, we cannot use it to determine the
8941 location of the tag, and therefore compute the tagged type's actual type.
8942 So we return the tagged type without consulting the tag. */
529cad9c 8943
f192137b
JB
8944static struct type *
8945ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8946 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8947{
61ee279c 8948 type = ada_check_typedef (type);
d2e4a39e
AS
8949 switch (TYPE_CODE (type))
8950 {
8951 default:
14f9c5c9 8952 return type;
d2e4a39e 8953 case TYPE_CODE_STRUCT:
4c4b4cd2 8954 {
76a01679 8955 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8956 struct type *fixed_record_type =
8957 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8958
529cad9c
PH
8959 /* If STATIC_TYPE is a tagged type and we know the object's address,
8960 then we can determine its tag, and compute the object's actual
0963b4bd 8961 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8962 type (the parent part of the record may have dynamic fields
8963 and the way the location of _tag is expressed may depend on
8964 them). */
529cad9c 8965
1ed6ede0 8966 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8967 {
b50d69b5
JG
8968 struct value *tag =
8969 value_tag_from_contents_and_address
8970 (fixed_record_type,
8971 valaddr,
8972 address);
8973 struct type *real_type = type_from_tag (tag);
8974 struct value *obj =
8975 value_from_contents_and_address (fixed_record_type,
8976 valaddr,
8977 address);
9f1f738a 8978 fixed_record_type = value_type (obj);
76a01679 8979 if (real_type != NULL)
b50d69b5
JG
8980 return to_fixed_record_type
8981 (real_type, NULL,
8982 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8983 }
4af88198
JB
8984
8985 /* Check to see if there is a parallel ___XVZ variable.
8986 If there is, then it provides the actual size of our type. */
8987 else if (ada_type_name (fixed_record_type) != NULL)
8988 {
0d5cff50 8989 const char *name = ada_type_name (fixed_record_type);
224c3ddb
SM
8990 char *xvz_name
8991 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
4af88198
JB
8992 int xvz_found = 0;
8993 LONGEST size;
8994
88c15c34 8995 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8996 size = get_int_var_value (xvz_name, &xvz_found);
8997 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8998 {
8999 fixed_record_type = copy_type (fixed_record_type);
9000 TYPE_LENGTH (fixed_record_type) = size;
9001
9002 /* The FIXED_RECORD_TYPE may have be a stub. We have
9003 observed this when the debugging info is STABS, and
9004 apparently it is something that is hard to fix.
9005
9006 In practice, we don't need the actual type definition
9007 at all, because the presence of the XVZ variable allows us
9008 to assume that there must be a XVS type as well, which we
9009 should be able to use later, when we need the actual type
9010 definition.
9011
9012 In the meantime, pretend that the "fixed" type we are
9013 returning is NOT a stub, because this can cause trouble
9014 when using this type to create new types targeting it.
9015 Indeed, the associated creation routines often check
9016 whether the target type is a stub and will try to replace
0963b4bd 9017 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
9018 might cause the new type to have the wrong size too.
9019 Consider the case of an array, for instance, where the size
9020 of the array is computed from the number of elements in
9021 our array multiplied by the size of its element. */
9022 TYPE_STUB (fixed_record_type) = 0;
9023 }
9024 }
1ed6ede0 9025 return fixed_record_type;
4c4b4cd2 9026 }
d2e4a39e 9027 case TYPE_CODE_ARRAY:
4c4b4cd2 9028 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
9029 case TYPE_CODE_UNION:
9030 if (dval == NULL)
4c4b4cd2 9031 return type;
d2e4a39e 9032 else
4c4b4cd2 9033 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 9034 }
14f9c5c9
AS
9035}
9036
f192137b
JB
9037/* The same as ada_to_fixed_type_1, except that it preserves the type
9038 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
9039
9040 The typedef layer needs be preserved in order to differentiate between
9041 arrays and array pointers when both types are implemented using the same
9042 fat pointer. In the array pointer case, the pointer is encoded as
9043 a typedef of the pointer type. For instance, considering:
9044
9045 type String_Access is access String;
9046 S1 : String_Access := null;
9047
9048 To the debugger, S1 is defined as a typedef of type String. But
9049 to the user, it is a pointer. So if the user tries to print S1,
9050 we should not dereference the array, but print the array address
9051 instead.
9052
9053 If we didn't preserve the typedef layer, we would lose the fact that
9054 the type is to be presented as a pointer (needs de-reference before
9055 being printed). And we would also use the source-level type name. */
f192137b
JB
9056
9057struct type *
9058ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9059 CORE_ADDR address, struct value *dval, int check_tag)
9060
9061{
9062 struct type *fixed_type =
9063 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9064
96dbd2c1
JB
9065 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9066 then preserve the typedef layer.
9067
9068 Implementation note: We can only check the main-type portion of
9069 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9070 from TYPE now returns a type that has the same instance flags
9071 as TYPE. For instance, if TYPE is a "typedef const", and its
9072 target type is a "struct", then the typedef elimination will return
9073 a "const" version of the target type. See check_typedef for more
9074 details about how the typedef layer elimination is done.
9075
9076 brobecker/2010-11-19: It seems to me that the only case where it is
9077 useful to preserve the typedef layer is when dealing with fat pointers.
9078 Perhaps, we could add a check for that and preserve the typedef layer
9079 only in that situation. But this seems unecessary so far, probably
9080 because we call check_typedef/ada_check_typedef pretty much everywhere.
9081 */
f192137b 9082 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 9083 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 9084 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
9085 return type;
9086
9087 return fixed_type;
9088}
9089
14f9c5c9 9090/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 9091 TYPE0, but based on no runtime data. */
14f9c5c9 9092
d2e4a39e
AS
9093static struct type *
9094to_static_fixed_type (struct type *type0)
14f9c5c9 9095{
d2e4a39e 9096 struct type *type;
14f9c5c9
AS
9097
9098 if (type0 == NULL)
9099 return NULL;
9100
876cecd0 9101 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
9102 return type0;
9103
61ee279c 9104 type0 = ada_check_typedef (type0);
d2e4a39e 9105
14f9c5c9
AS
9106 switch (TYPE_CODE (type0))
9107 {
9108 default:
9109 return type0;
9110 case TYPE_CODE_STRUCT:
9111 type = dynamic_template_type (type0);
d2e4a39e 9112 if (type != NULL)
4c4b4cd2
PH
9113 return template_to_static_fixed_type (type);
9114 else
9115 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9116 case TYPE_CODE_UNION:
9117 type = ada_find_parallel_type (type0, "___XVU");
9118 if (type != NULL)
4c4b4cd2
PH
9119 return template_to_static_fixed_type (type);
9120 else
9121 return template_to_static_fixed_type (type0);
14f9c5c9
AS
9122 }
9123}
9124
4c4b4cd2
PH
9125/* A static approximation of TYPE with all type wrappers removed. */
9126
d2e4a39e
AS
9127static struct type *
9128static_unwrap_type (struct type *type)
14f9c5c9
AS
9129{
9130 if (ada_is_aligner_type (type))
9131 {
61ee279c 9132 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 9133 if (ada_type_name (type1) == NULL)
4c4b4cd2 9134 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
9135
9136 return static_unwrap_type (type1);
9137 }
d2e4a39e 9138 else
14f9c5c9 9139 {
d2e4a39e 9140 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 9141
d2e4a39e 9142 if (raw_real_type == type)
4c4b4cd2 9143 return type;
14f9c5c9 9144 else
4c4b4cd2 9145 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
9146 }
9147}
9148
9149/* In some cases, incomplete and private types require
4c4b4cd2 9150 cross-references that are not resolved as records (for example,
14f9c5c9
AS
9151 type Foo;
9152 type FooP is access Foo;
9153 V: FooP;
9154 type Foo is array ...;
4c4b4cd2 9155 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
9156 cross-references to such types, we instead substitute for FooP a
9157 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 9158 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
9159
9160/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
9161 exists, otherwise TYPE. */
9162
d2e4a39e 9163struct type *
61ee279c 9164ada_check_typedef (struct type *type)
14f9c5c9 9165{
727e3d2e
JB
9166 if (type == NULL)
9167 return NULL;
9168
720d1a40
JB
9169 /* If our type is a typedef type of a fat pointer, then we're done.
9170 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9171 what allows us to distinguish between fat pointers that represent
9172 array types, and fat pointers that represent array access types
9173 (in both cases, the compiler implements them as fat pointers). */
9174 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9175 && is_thick_pntr (ada_typedef_target_type (type)))
9176 return type;
9177
f168693b 9178 type = check_typedef (type);
14f9c5c9 9179 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 9180 || !TYPE_STUB (type)
14f9c5c9
AS
9181 || TYPE_TAG_NAME (type) == NULL)
9182 return type;
d2e4a39e 9183 else
14f9c5c9 9184 {
0d5cff50 9185 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 9186 struct type *type1 = ada_find_any_type (name);
5b4ee69b 9187
05e522ef
JB
9188 if (type1 == NULL)
9189 return type;
9190
9191 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9192 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
9193 types, only for the typedef-to-array types). If that's the case,
9194 strip the typedef layer. */
9195 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9196 type1 = ada_check_typedef (type1);
9197
9198 return type1;
14f9c5c9
AS
9199 }
9200}
9201
9202/* A value representing the data at VALADDR/ADDRESS as described by
9203 type TYPE0, but with a standard (static-sized) type that correctly
9204 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9205 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 9206 creation of struct values]. */
14f9c5c9 9207
4c4b4cd2
PH
9208static struct value *
9209ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9210 struct value *val0)
14f9c5c9 9211{
1ed6ede0 9212 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 9213
14f9c5c9
AS
9214 if (type == type0 && val0 != NULL)
9215 return val0;
d2e4a39e 9216 else
4c4b4cd2
PH
9217 return value_from_contents_and_address (type, 0, address);
9218}
9219
9220/* A value representing VAL, but with a standard (static-sized) type
9221 that correctly describes it. Does not necessarily create a new
9222 value. */
9223
0c3acc09 9224struct value *
4c4b4cd2
PH
9225ada_to_fixed_value (struct value *val)
9226{
c48db5ca
JB
9227 val = unwrap_value (val);
9228 val = ada_to_fixed_value_create (value_type (val),
9229 value_address (val),
9230 val);
9231 return val;
14f9c5c9 9232}
d2e4a39e 9233\f
14f9c5c9 9234
14f9c5c9
AS
9235/* Attributes */
9236
4c4b4cd2
PH
9237/* Table mapping attribute numbers to names.
9238 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9239
d2e4a39e 9240static const char *attribute_names[] = {
14f9c5c9
AS
9241 "<?>",
9242
d2e4a39e 9243 "first",
14f9c5c9
AS
9244 "last",
9245 "length",
9246 "image",
14f9c5c9
AS
9247 "max",
9248 "min",
4c4b4cd2
PH
9249 "modulus",
9250 "pos",
9251 "size",
9252 "tag",
14f9c5c9 9253 "val",
14f9c5c9
AS
9254 0
9255};
9256
d2e4a39e 9257const char *
4c4b4cd2 9258ada_attribute_name (enum exp_opcode n)
14f9c5c9 9259{
4c4b4cd2
PH
9260 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9261 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9262 else
9263 return attribute_names[0];
9264}
9265
4c4b4cd2 9266/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9267
4c4b4cd2
PH
9268static LONGEST
9269pos_atr (struct value *arg)
14f9c5c9 9270{
24209737
PH
9271 struct value *val = coerce_ref (arg);
9272 struct type *type = value_type (val);
aa715135 9273 LONGEST result;
14f9c5c9 9274
d2e4a39e 9275 if (!discrete_type_p (type))
323e0a4a 9276 error (_("'POS only defined on discrete types"));
14f9c5c9 9277
aa715135
JG
9278 if (!discrete_position (type, value_as_long (val), &result))
9279 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9280
aa715135 9281 return result;
4c4b4cd2
PH
9282}
9283
9284static struct value *
3cb382c9 9285value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9286{
3cb382c9 9287 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9288}
9289
4c4b4cd2 9290/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9291
d2e4a39e
AS
9292static struct value *
9293value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9294{
d2e4a39e 9295 if (!discrete_type_p (type))
323e0a4a 9296 error (_("'VAL only defined on discrete types"));
df407dfe 9297 if (!integer_type_p (value_type (arg)))
323e0a4a 9298 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9299
9300 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9301 {
9302 long pos = value_as_long (arg);
5b4ee69b 9303
14f9c5c9 9304 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9305 error (_("argument to 'VAL out of range"));
14e75d8e 9306 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9307 }
9308 else
9309 return value_from_longest (type, value_as_long (arg));
9310}
14f9c5c9 9311\f
d2e4a39e 9312
4c4b4cd2 9313 /* Evaluation */
14f9c5c9 9314
4c4b4cd2
PH
9315/* True if TYPE appears to be an Ada character type.
9316 [At the moment, this is true only for Character and Wide_Character;
9317 It is a heuristic test that could stand improvement]. */
14f9c5c9 9318
d2e4a39e
AS
9319int
9320ada_is_character_type (struct type *type)
14f9c5c9 9321{
7b9f71f2
JB
9322 const char *name;
9323
9324 /* If the type code says it's a character, then assume it really is,
9325 and don't check any further. */
9326 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9327 return 1;
9328
9329 /* Otherwise, assume it's a character type iff it is a discrete type
9330 with a known character type name. */
9331 name = ada_type_name (type);
9332 return (name != NULL
9333 && (TYPE_CODE (type) == TYPE_CODE_INT
9334 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9335 && (strcmp (name, "character") == 0
9336 || strcmp (name, "wide_character") == 0
5a517ebd 9337 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9338 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9339}
9340
4c4b4cd2 9341/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9342
9343int
ebf56fd3 9344ada_is_string_type (struct type *type)
14f9c5c9 9345{
61ee279c 9346 type = ada_check_typedef (type);
d2e4a39e 9347 if (type != NULL
14f9c5c9 9348 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9349 && (ada_is_simple_array_type (type)
9350 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9351 && ada_array_arity (type) == 1)
9352 {
9353 struct type *elttype = ada_array_element_type (type, 1);
9354
9355 return ada_is_character_type (elttype);
9356 }
d2e4a39e 9357 else
14f9c5c9
AS
9358 return 0;
9359}
9360
5bf03f13
JB
9361/* The compiler sometimes provides a parallel XVS type for a given
9362 PAD type. Normally, it is safe to follow the PAD type directly,
9363 but older versions of the compiler have a bug that causes the offset
9364 of its "F" field to be wrong. Following that field in that case
9365 would lead to incorrect results, but this can be worked around
9366 by ignoring the PAD type and using the associated XVS type instead.
9367
9368 Set to True if the debugger should trust the contents of PAD types.
9369 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9370static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9371
9372/* True if TYPE is a struct type introduced by the compiler to force the
9373 alignment of a value. Such types have a single field with a
4c4b4cd2 9374 distinctive name. */
14f9c5c9
AS
9375
9376int
ebf56fd3 9377ada_is_aligner_type (struct type *type)
14f9c5c9 9378{
61ee279c 9379 type = ada_check_typedef (type);
714e53ab 9380
5bf03f13 9381 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9382 return 0;
9383
14f9c5c9 9384 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9385 && TYPE_NFIELDS (type) == 1
9386 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9387}
9388
9389/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9390 the parallel type. */
14f9c5c9 9391
d2e4a39e
AS
9392struct type *
9393ada_get_base_type (struct type *raw_type)
14f9c5c9 9394{
d2e4a39e
AS
9395 struct type *real_type_namer;
9396 struct type *raw_real_type;
14f9c5c9
AS
9397
9398 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9399 return raw_type;
9400
284614f0
JB
9401 if (ada_is_aligner_type (raw_type))
9402 /* The encoding specifies that we should always use the aligner type.
9403 So, even if this aligner type has an associated XVS type, we should
9404 simply ignore it.
9405
9406 According to the compiler gurus, an XVS type parallel to an aligner
9407 type may exist because of a stabs limitation. In stabs, aligner
9408 types are empty because the field has a variable-sized type, and
9409 thus cannot actually be used as an aligner type. As a result,
9410 we need the associated parallel XVS type to decode the type.
9411 Since the policy in the compiler is to not change the internal
9412 representation based on the debugging info format, we sometimes
9413 end up having a redundant XVS type parallel to the aligner type. */
9414 return raw_type;
9415
14f9c5c9 9416 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9417 if (real_type_namer == NULL
14f9c5c9
AS
9418 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9419 || TYPE_NFIELDS (real_type_namer) != 1)
9420 return raw_type;
9421
f80d3ff2
JB
9422 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9423 {
9424 /* This is an older encoding form where the base type needs to be
9425 looked up by name. We prefer the newer enconding because it is
9426 more efficient. */
9427 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9428 if (raw_real_type == NULL)
9429 return raw_type;
9430 else
9431 return raw_real_type;
9432 }
9433
9434 /* The field in our XVS type is a reference to the base type. */
9435 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9436}
14f9c5c9 9437
4c4b4cd2 9438/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9439
d2e4a39e
AS
9440struct type *
9441ada_aligned_type (struct type *type)
14f9c5c9
AS
9442{
9443 if (ada_is_aligner_type (type))
9444 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9445 else
9446 return ada_get_base_type (type);
9447}
9448
9449
9450/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9451 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9452
fc1a4b47
AC
9453const gdb_byte *
9454ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9455{
d2e4a39e 9456 if (ada_is_aligner_type (type))
14f9c5c9 9457 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9458 valaddr +
9459 TYPE_FIELD_BITPOS (type,
9460 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9461 else
9462 return valaddr;
9463}
9464
4c4b4cd2
PH
9465
9466
14f9c5c9 9467/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9468 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9469const char *
9470ada_enum_name (const char *name)
14f9c5c9 9471{
4c4b4cd2
PH
9472 static char *result;
9473 static size_t result_len = 0;
e6a959d6 9474 const char *tmp;
14f9c5c9 9475
4c4b4cd2
PH
9476 /* First, unqualify the enumeration name:
9477 1. Search for the last '.' character. If we find one, then skip
177b42fe 9478 all the preceding characters, the unqualified name starts
76a01679 9479 right after that dot.
4c4b4cd2 9480 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9481 translates dots into "__". Search forward for double underscores,
9482 but stop searching when we hit an overloading suffix, which is
9483 of the form "__" followed by digits. */
4c4b4cd2 9484
c3e5cd34
PH
9485 tmp = strrchr (name, '.');
9486 if (tmp != NULL)
4c4b4cd2
PH
9487 name = tmp + 1;
9488 else
14f9c5c9 9489 {
4c4b4cd2
PH
9490 while ((tmp = strstr (name, "__")) != NULL)
9491 {
9492 if (isdigit (tmp[2]))
9493 break;
9494 else
9495 name = tmp + 2;
9496 }
14f9c5c9
AS
9497 }
9498
9499 if (name[0] == 'Q')
9500 {
14f9c5c9 9501 int v;
5b4ee69b 9502
14f9c5c9 9503 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9504 {
9505 if (sscanf (name + 2, "%x", &v) != 1)
9506 return name;
9507 }
14f9c5c9 9508 else
4c4b4cd2 9509 return name;
14f9c5c9 9510
4c4b4cd2 9511 GROW_VECT (result, result_len, 16);
14f9c5c9 9512 if (isascii (v) && isprint (v))
88c15c34 9513 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9514 else if (name[1] == 'U')
88c15c34 9515 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9516 else
88c15c34 9517 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9518
9519 return result;
9520 }
d2e4a39e 9521 else
4c4b4cd2 9522 {
c3e5cd34
PH
9523 tmp = strstr (name, "__");
9524 if (tmp == NULL)
9525 tmp = strstr (name, "$");
9526 if (tmp != NULL)
4c4b4cd2
PH
9527 {
9528 GROW_VECT (result, result_len, tmp - name + 1);
9529 strncpy (result, name, tmp - name);
9530 result[tmp - name] = '\0';
9531 return result;
9532 }
9533
9534 return name;
9535 }
14f9c5c9
AS
9536}
9537
14f9c5c9
AS
9538/* Evaluate the subexpression of EXP starting at *POS as for
9539 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9540 expression. */
14f9c5c9 9541
d2e4a39e
AS
9542static struct value *
9543evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9544{
4b27a620 9545 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9546}
9547
9548/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9549 value it wraps. */
14f9c5c9 9550
d2e4a39e
AS
9551static struct value *
9552unwrap_value (struct value *val)
14f9c5c9 9553{
df407dfe 9554 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9555
14f9c5c9
AS
9556 if (ada_is_aligner_type (type))
9557 {
de4d072f 9558 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9559 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9560
14f9c5c9 9561 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9562 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9563
9564 return unwrap_value (v);
9565 }
d2e4a39e 9566 else
14f9c5c9 9567 {
d2e4a39e 9568 struct type *raw_real_type =
61ee279c 9569 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9570
5bf03f13
JB
9571 /* If there is no parallel XVS or XVE type, then the value is
9572 already unwrapped. Return it without further modification. */
9573 if ((type == raw_real_type)
9574 && ada_find_parallel_type (type, "___XVE") == NULL)
9575 return val;
14f9c5c9 9576
d2e4a39e 9577 return
4c4b4cd2
PH
9578 coerce_unspec_val_to_type
9579 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9580 value_address (val),
1ed6ede0 9581 NULL, 1));
14f9c5c9
AS
9582 }
9583}
d2e4a39e
AS
9584
9585static struct value *
9586cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
9587{
9588 LONGEST val;
9589
df407dfe 9590 if (type == value_type (arg))
14f9c5c9 9591 return arg;
df407dfe 9592 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 9593 val = ada_float_to_fixed (type,
df407dfe 9594 ada_fixed_to_float (value_type (arg),
4c4b4cd2 9595 value_as_long (arg)));
d2e4a39e 9596 else
14f9c5c9 9597 {
a53b7a21 9598 DOUBLEST argd = value_as_double (arg);
5b4ee69b 9599
14f9c5c9
AS
9600 val = ada_float_to_fixed (type, argd);
9601 }
9602
9603 return value_from_longest (type, val);
9604}
9605
d2e4a39e 9606static struct value *
a53b7a21 9607cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9608{
df407dfe 9609 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 9610 value_as_long (arg));
5b4ee69b 9611
a53b7a21 9612 return value_from_double (type, val);
14f9c5c9
AS
9613}
9614
d99dcf51
JB
9615/* Given two array types T1 and T2, return nonzero iff both arrays
9616 contain the same number of elements. */
9617
9618static int
9619ada_same_array_size_p (struct type *t1, struct type *t2)
9620{
9621 LONGEST lo1, hi1, lo2, hi2;
9622
9623 /* Get the array bounds in order to verify that the size of
9624 the two arrays match. */
9625 if (!get_array_bounds (t1, &lo1, &hi1)
9626 || !get_array_bounds (t2, &lo2, &hi2))
9627 error (_("unable to determine array bounds"));
9628
9629 /* To make things easier for size comparison, normalize a bit
9630 the case of empty arrays by making sure that the difference
9631 between upper bound and lower bound is always -1. */
9632 if (lo1 > hi1)
9633 hi1 = lo1 - 1;
9634 if (lo2 > hi2)
9635 hi2 = lo2 - 1;
9636
9637 return (hi1 - lo1 == hi2 - lo2);
9638}
9639
9640/* Assuming that VAL is an array of integrals, and TYPE represents
9641 an array with the same number of elements, but with wider integral
9642 elements, return an array "casted" to TYPE. In practice, this
9643 means that the returned array is built by casting each element
9644 of the original array into TYPE's (wider) element type. */
9645
9646static struct value *
9647ada_promote_array_of_integrals (struct type *type, struct value *val)
9648{
9649 struct type *elt_type = TYPE_TARGET_TYPE (type);
9650 LONGEST lo, hi;
9651 struct value *res;
9652 LONGEST i;
9653
9654 /* Verify that both val and type are arrays of scalars, and
9655 that the size of val's elements is smaller than the size
9656 of type's element. */
9657 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9658 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9659 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9660 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9661 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9662 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9663
9664 if (!get_array_bounds (type, &lo, &hi))
9665 error (_("unable to determine array bounds"));
9666
9667 res = allocate_value (type);
9668
9669 /* Promote each array element. */
9670 for (i = 0; i < hi - lo + 1; i++)
9671 {
9672 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9673
9674 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9675 value_contents_all (elt), TYPE_LENGTH (elt_type));
9676 }
9677
9678 return res;
9679}
9680
4c4b4cd2
PH
9681/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9682 return the converted value. */
9683
d2e4a39e
AS
9684static struct value *
9685coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9686{
df407dfe 9687 struct type *type2 = value_type (val);
5b4ee69b 9688
14f9c5c9
AS
9689 if (type == type2)
9690 return val;
9691
61ee279c
PH
9692 type2 = ada_check_typedef (type2);
9693 type = ada_check_typedef (type);
14f9c5c9 9694
d2e4a39e
AS
9695 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9696 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9697 {
9698 val = ada_value_ind (val);
df407dfe 9699 type2 = value_type (val);
14f9c5c9
AS
9700 }
9701
d2e4a39e 9702 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9703 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9704 {
d99dcf51
JB
9705 if (!ada_same_array_size_p (type, type2))
9706 error (_("cannot assign arrays of different length"));
9707
9708 if (is_integral_type (TYPE_TARGET_TYPE (type))
9709 && is_integral_type (TYPE_TARGET_TYPE (type2))
9710 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9711 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9712 {
9713 /* Allow implicit promotion of the array elements to
9714 a wider type. */
9715 return ada_promote_array_of_integrals (type, val);
9716 }
9717
9718 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9719 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9720 error (_("Incompatible types in assignment"));
04624583 9721 deprecated_set_value_type (val, type);
14f9c5c9 9722 }
d2e4a39e 9723 return val;
14f9c5c9
AS
9724}
9725
4c4b4cd2
PH
9726static struct value *
9727ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9728{
9729 struct value *val;
9730 struct type *type1, *type2;
9731 LONGEST v, v1, v2;
9732
994b9211
AC
9733 arg1 = coerce_ref (arg1);
9734 arg2 = coerce_ref (arg2);
18af8284
JB
9735 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9736 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9737
76a01679
JB
9738 if (TYPE_CODE (type1) != TYPE_CODE_INT
9739 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9740 return value_binop (arg1, arg2, op);
9741
76a01679 9742 switch (op)
4c4b4cd2
PH
9743 {
9744 case BINOP_MOD:
9745 case BINOP_DIV:
9746 case BINOP_REM:
9747 break;
9748 default:
9749 return value_binop (arg1, arg2, op);
9750 }
9751
9752 v2 = value_as_long (arg2);
9753 if (v2 == 0)
323e0a4a 9754 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9755
9756 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9757 return value_binop (arg1, arg2, op);
9758
9759 v1 = value_as_long (arg1);
9760 switch (op)
9761 {
9762 case BINOP_DIV:
9763 v = v1 / v2;
76a01679
JB
9764 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9765 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9766 break;
9767 case BINOP_REM:
9768 v = v1 % v2;
76a01679
JB
9769 if (v * v1 < 0)
9770 v -= v2;
4c4b4cd2
PH
9771 break;
9772 default:
9773 /* Should not reach this point. */
9774 v = 0;
9775 }
9776
9777 val = allocate_value (type1);
990a07ab 9778 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9779 TYPE_LENGTH (value_type (val)),
9780 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9781 return val;
9782}
9783
9784static int
9785ada_value_equal (struct value *arg1, struct value *arg2)
9786{
df407dfe
AC
9787 if (ada_is_direct_array_type (value_type (arg1))
9788 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9789 {
f58b38bf
JB
9790 /* Automatically dereference any array reference before
9791 we attempt to perform the comparison. */
9792 arg1 = ada_coerce_ref (arg1);
9793 arg2 = ada_coerce_ref (arg2);
9794
4c4b4cd2
PH
9795 arg1 = ada_coerce_to_simple_array (arg1);
9796 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9797 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9798 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9799 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9800 /* FIXME: The following works only for types whose
76a01679
JB
9801 representations use all bits (no padding or undefined bits)
9802 and do not have user-defined equality. */
9803 return
df407dfe 9804 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9805 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9806 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9807 }
9808 return value_equal (arg1, arg2);
9809}
9810
52ce6436
PH
9811/* Total number of component associations in the aggregate starting at
9812 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9813 OP_AGGREGATE. */
52ce6436
PH
9814
9815static int
9816num_component_specs (struct expression *exp, int pc)
9817{
9818 int n, m, i;
5b4ee69b 9819
52ce6436
PH
9820 m = exp->elts[pc + 1].longconst;
9821 pc += 3;
9822 n = 0;
9823 for (i = 0; i < m; i += 1)
9824 {
9825 switch (exp->elts[pc].opcode)
9826 {
9827 default:
9828 n += 1;
9829 break;
9830 case OP_CHOICES:
9831 n += exp->elts[pc + 1].longconst;
9832 break;
9833 }
9834 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9835 }
9836 return n;
9837}
9838
9839/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9840 component of LHS (a simple array or a record), updating *POS past
9841 the expression, assuming that LHS is contained in CONTAINER. Does
9842 not modify the inferior's memory, nor does it modify LHS (unless
9843 LHS == CONTAINER). */
9844
9845static void
9846assign_component (struct value *container, struct value *lhs, LONGEST index,
9847 struct expression *exp, int *pos)
9848{
9849 struct value *mark = value_mark ();
9850 struct value *elt;
5b4ee69b 9851
52ce6436
PH
9852 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9853 {
22601c15
UW
9854 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9855 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9856
52ce6436
PH
9857 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9858 }
9859 else
9860 {
9861 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9862 elt = ada_to_fixed_value (elt);
52ce6436
PH
9863 }
9864
9865 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9866 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9867 else
9868 value_assign_to_component (container, elt,
9869 ada_evaluate_subexp (NULL, exp, pos,
9870 EVAL_NORMAL));
9871
9872 value_free_to_mark (mark);
9873}
9874
9875/* Assuming that LHS represents an lvalue having a record or array
9876 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9877 of that aggregate's value to LHS, advancing *POS past the
9878 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9879 lvalue containing LHS (possibly LHS itself). Does not modify
9880 the inferior's memory, nor does it modify the contents of
0963b4bd 9881 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9882
9883static struct value *
9884assign_aggregate (struct value *container,
9885 struct value *lhs, struct expression *exp,
9886 int *pos, enum noside noside)
9887{
9888 struct type *lhs_type;
9889 int n = exp->elts[*pos+1].longconst;
9890 LONGEST low_index, high_index;
9891 int num_specs;
9892 LONGEST *indices;
9893 int max_indices, num_indices;
52ce6436 9894 int i;
52ce6436
PH
9895
9896 *pos += 3;
9897 if (noside != EVAL_NORMAL)
9898 {
52ce6436
PH
9899 for (i = 0; i < n; i += 1)
9900 ada_evaluate_subexp (NULL, exp, pos, noside);
9901 return container;
9902 }
9903
9904 container = ada_coerce_ref (container);
9905 if (ada_is_direct_array_type (value_type (container)))
9906 container = ada_coerce_to_simple_array (container);
9907 lhs = ada_coerce_ref (lhs);
9908 if (!deprecated_value_modifiable (lhs))
9909 error (_("Left operand of assignment is not a modifiable lvalue."));
9910
9911 lhs_type = value_type (lhs);
9912 if (ada_is_direct_array_type (lhs_type))
9913 {
9914 lhs = ada_coerce_to_simple_array (lhs);
9915 lhs_type = value_type (lhs);
9916 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9917 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9918 }
9919 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9920 {
9921 low_index = 0;
9922 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9923 }
9924 else
9925 error (_("Left-hand side must be array or record."));
9926
9927 num_specs = num_component_specs (exp, *pos - 3);
9928 max_indices = 4 * num_specs + 4;
8d749320 9929 indices = XALLOCAVEC (LONGEST, max_indices);
52ce6436
PH
9930 indices[0] = indices[1] = low_index - 1;
9931 indices[2] = indices[3] = high_index + 1;
9932 num_indices = 4;
9933
9934 for (i = 0; i < n; i += 1)
9935 {
9936 switch (exp->elts[*pos].opcode)
9937 {
1fbf5ada
JB
9938 case OP_CHOICES:
9939 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9940 &num_indices, max_indices,
9941 low_index, high_index);
9942 break;
9943 case OP_POSITIONAL:
9944 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9945 &num_indices, max_indices,
9946 low_index, high_index);
1fbf5ada
JB
9947 break;
9948 case OP_OTHERS:
9949 if (i != n-1)
9950 error (_("Misplaced 'others' clause"));
9951 aggregate_assign_others (container, lhs, exp, pos, indices,
9952 num_indices, low_index, high_index);
9953 break;
9954 default:
9955 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9956 }
9957 }
9958
9959 return container;
9960}
9961
9962/* Assign into the component of LHS indexed by the OP_POSITIONAL
9963 construct at *POS, updating *POS past the construct, given that
9964 the positions are relative to lower bound LOW, where HIGH is the
9965 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9966 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9967 assign_aggregate. */
52ce6436
PH
9968static void
9969aggregate_assign_positional (struct value *container,
9970 struct value *lhs, struct expression *exp,
9971 int *pos, LONGEST *indices, int *num_indices,
9972 int max_indices, LONGEST low, LONGEST high)
9973{
9974 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9975
9976 if (ind - 1 == high)
e1d5a0d2 9977 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9978 if (ind <= high)
9979 {
9980 add_component_interval (ind, ind, indices, num_indices, max_indices);
9981 *pos += 3;
9982 assign_component (container, lhs, ind, exp, pos);
9983 }
9984 else
9985 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9986}
9987
9988/* Assign into the components of LHS indexed by the OP_CHOICES
9989 construct at *POS, updating *POS past the construct, given that
9990 the allowable indices are LOW..HIGH. Record the indices assigned
9991 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9992 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9993static void
9994aggregate_assign_from_choices (struct value *container,
9995 struct value *lhs, struct expression *exp,
9996 int *pos, LONGEST *indices, int *num_indices,
9997 int max_indices, LONGEST low, LONGEST high)
9998{
9999 int j;
10000 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10001 int choice_pos, expr_pc;
10002 int is_array = ada_is_direct_array_type (value_type (lhs));
10003
10004 choice_pos = *pos += 3;
10005
10006 for (j = 0; j < n_choices; j += 1)
10007 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10008 expr_pc = *pos;
10009 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10010
10011 for (j = 0; j < n_choices; j += 1)
10012 {
10013 LONGEST lower, upper;
10014 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 10015
52ce6436
PH
10016 if (op == OP_DISCRETE_RANGE)
10017 {
10018 choice_pos += 1;
10019 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10020 EVAL_NORMAL));
10021 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10022 EVAL_NORMAL));
10023 }
10024 else if (is_array)
10025 {
10026 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10027 EVAL_NORMAL));
10028 upper = lower;
10029 }
10030 else
10031 {
10032 int ind;
0d5cff50 10033 const char *name;
5b4ee69b 10034
52ce6436
PH
10035 switch (op)
10036 {
10037 case OP_NAME:
10038 name = &exp->elts[choice_pos + 2].string;
10039 break;
10040 case OP_VAR_VALUE:
10041 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10042 break;
10043 default:
10044 error (_("Invalid record component association."));
10045 }
10046 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10047 ind = 0;
10048 if (! find_struct_field (name, value_type (lhs), 0,
10049 NULL, NULL, NULL, NULL, &ind))
10050 error (_("Unknown component name: %s."), name);
10051 lower = upper = ind;
10052 }
10053
10054 if (lower <= upper && (lower < low || upper > high))
10055 error (_("Index in component association out of bounds."));
10056
10057 add_component_interval (lower, upper, indices, num_indices,
10058 max_indices);
10059 while (lower <= upper)
10060 {
10061 int pos1;
5b4ee69b 10062
52ce6436
PH
10063 pos1 = expr_pc;
10064 assign_component (container, lhs, lower, exp, &pos1);
10065 lower += 1;
10066 }
10067 }
10068}
10069
10070/* Assign the value of the expression in the OP_OTHERS construct in
10071 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10072 have not been previously assigned. The index intervals already assigned
10073 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 10074 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
10075static void
10076aggregate_assign_others (struct value *container,
10077 struct value *lhs, struct expression *exp,
10078 int *pos, LONGEST *indices, int num_indices,
10079 LONGEST low, LONGEST high)
10080{
10081 int i;
5ce64950 10082 int expr_pc = *pos + 1;
52ce6436
PH
10083
10084 for (i = 0; i < num_indices - 2; i += 2)
10085 {
10086 LONGEST ind;
5b4ee69b 10087
52ce6436
PH
10088 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10089 {
5ce64950 10090 int localpos;
5b4ee69b 10091
5ce64950
MS
10092 localpos = expr_pc;
10093 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
10094 }
10095 }
10096 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10097}
10098
10099/* Add the interval [LOW .. HIGH] to the sorted set of intervals
10100 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10101 modifying *SIZE as needed. It is an error if *SIZE exceeds
10102 MAX_SIZE. The resulting intervals do not overlap. */
10103static void
10104add_component_interval (LONGEST low, LONGEST high,
10105 LONGEST* indices, int *size, int max_size)
10106{
10107 int i, j;
5b4ee69b 10108
52ce6436
PH
10109 for (i = 0; i < *size; i += 2) {
10110 if (high >= indices[i] && low <= indices[i + 1])
10111 {
10112 int kh;
5b4ee69b 10113
52ce6436
PH
10114 for (kh = i + 2; kh < *size; kh += 2)
10115 if (high < indices[kh])
10116 break;
10117 if (low < indices[i])
10118 indices[i] = low;
10119 indices[i + 1] = indices[kh - 1];
10120 if (high > indices[i + 1])
10121 indices[i + 1] = high;
10122 memcpy (indices + i + 2, indices + kh, *size - kh);
10123 *size -= kh - i - 2;
10124 return;
10125 }
10126 else if (high < indices[i])
10127 break;
10128 }
10129
10130 if (*size == max_size)
10131 error (_("Internal error: miscounted aggregate components."));
10132 *size += 2;
10133 for (j = *size-1; j >= i+2; j -= 1)
10134 indices[j] = indices[j - 2];
10135 indices[i] = low;
10136 indices[i + 1] = high;
10137}
10138
6e48bd2c
JB
10139/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10140 is different. */
10141
10142static struct value *
10143ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
10144{
10145 if (type == ada_check_typedef (value_type (arg2)))
10146 return arg2;
10147
10148 if (ada_is_fixed_point_type (type))
10149 return (cast_to_fixed (type, arg2));
10150
10151 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10152 return cast_from_fixed (type, arg2);
6e48bd2c
JB
10153
10154 return value_cast (type, arg2);
10155}
10156
284614f0
JB
10157/* Evaluating Ada expressions, and printing their result.
10158 ------------------------------------------------------
10159
21649b50
JB
10160 1. Introduction:
10161 ----------------
10162
284614f0
JB
10163 We usually evaluate an Ada expression in order to print its value.
10164 We also evaluate an expression in order to print its type, which
10165 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10166 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10167 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10168 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10169 similar.
10170
10171 Evaluating expressions is a little more complicated for Ada entities
10172 than it is for entities in languages such as C. The main reason for
10173 this is that Ada provides types whose definition might be dynamic.
10174 One example of such types is variant records. Or another example
10175 would be an array whose bounds can only be known at run time.
10176
10177 The following description is a general guide as to what should be
10178 done (and what should NOT be done) in order to evaluate an expression
10179 involving such types, and when. This does not cover how the semantic
10180 information is encoded by GNAT as this is covered separatly. For the
10181 document used as the reference for the GNAT encoding, see exp_dbug.ads
10182 in the GNAT sources.
10183
10184 Ideally, we should embed each part of this description next to its
10185 associated code. Unfortunately, the amount of code is so vast right
10186 now that it's hard to see whether the code handling a particular
10187 situation might be duplicated or not. One day, when the code is
10188 cleaned up, this guide might become redundant with the comments
10189 inserted in the code, and we might want to remove it.
10190
21649b50
JB
10191 2. ``Fixing'' an Entity, the Simple Case:
10192 -----------------------------------------
10193
284614f0
JB
10194 When evaluating Ada expressions, the tricky issue is that they may
10195 reference entities whose type contents and size are not statically
10196 known. Consider for instance a variant record:
10197
10198 type Rec (Empty : Boolean := True) is record
10199 case Empty is
10200 when True => null;
10201 when False => Value : Integer;
10202 end case;
10203 end record;
10204 Yes : Rec := (Empty => False, Value => 1);
10205 No : Rec := (empty => True);
10206
10207 The size and contents of that record depends on the value of the
10208 descriminant (Rec.Empty). At this point, neither the debugging
10209 information nor the associated type structure in GDB are able to
10210 express such dynamic types. So what the debugger does is to create
10211 "fixed" versions of the type that applies to the specific object.
10212 We also informally refer to this opperation as "fixing" an object,
10213 which means creating its associated fixed type.
10214
10215 Example: when printing the value of variable "Yes" above, its fixed
10216 type would look like this:
10217
10218 type Rec is record
10219 Empty : Boolean;
10220 Value : Integer;
10221 end record;
10222
10223 On the other hand, if we printed the value of "No", its fixed type
10224 would become:
10225
10226 type Rec is record
10227 Empty : Boolean;
10228 end record;
10229
10230 Things become a little more complicated when trying to fix an entity
10231 with a dynamic type that directly contains another dynamic type,
10232 such as an array of variant records, for instance. There are
10233 two possible cases: Arrays, and records.
10234
21649b50
JB
10235 3. ``Fixing'' Arrays:
10236 ---------------------
10237
10238 The type structure in GDB describes an array in terms of its bounds,
10239 and the type of its elements. By design, all elements in the array
10240 have the same type and we cannot represent an array of variant elements
10241 using the current type structure in GDB. When fixing an array,
10242 we cannot fix the array element, as we would potentially need one
10243 fixed type per element of the array. As a result, the best we can do
10244 when fixing an array is to produce an array whose bounds and size
10245 are correct (allowing us to read it from memory), but without having
10246 touched its element type. Fixing each element will be done later,
10247 when (if) necessary.
10248
10249 Arrays are a little simpler to handle than records, because the same
10250 amount of memory is allocated for each element of the array, even if
1b536f04 10251 the amount of space actually used by each element differs from element
21649b50 10252 to element. Consider for instance the following array of type Rec:
284614f0
JB
10253
10254 type Rec_Array is array (1 .. 2) of Rec;
10255
1b536f04
JB
10256 The actual amount of memory occupied by each element might be different
10257 from element to element, depending on the value of their discriminant.
21649b50 10258 But the amount of space reserved for each element in the array remains
1b536f04 10259 fixed regardless. So we simply need to compute that size using
21649b50
JB
10260 the debugging information available, from which we can then determine
10261 the array size (we multiply the number of elements of the array by
10262 the size of each element).
10263
10264 The simplest case is when we have an array of a constrained element
10265 type. For instance, consider the following type declarations:
10266
10267 type Bounded_String (Max_Size : Integer) is
10268 Length : Integer;
10269 Buffer : String (1 .. Max_Size);
10270 end record;
10271 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10272
10273 In this case, the compiler describes the array as an array of
10274 variable-size elements (identified by its XVS suffix) for which
10275 the size can be read in the parallel XVZ variable.
10276
10277 In the case of an array of an unconstrained element type, the compiler
10278 wraps the array element inside a private PAD type. This type should not
10279 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10280 that we also use the adjective "aligner" in our code to designate
10281 these wrapper types.
10282
1b536f04 10283 In some cases, the size allocated for each element is statically
21649b50
JB
10284 known. In that case, the PAD type already has the correct size,
10285 and the array element should remain unfixed.
10286
10287 But there are cases when this size is not statically known.
10288 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10289
10290 type Dynamic is array (1 .. Five) of Integer;
10291 type Wrapper (Has_Length : Boolean := False) is record
10292 Data : Dynamic;
10293 case Has_Length is
10294 when True => Length : Integer;
10295 when False => null;
10296 end case;
10297 end record;
10298 type Wrapper_Array is array (1 .. 2) of Wrapper;
10299
10300 Hello : Wrapper_Array := (others => (Has_Length => True,
10301 Data => (others => 17),
10302 Length => 1));
10303
10304
10305 The debugging info would describe variable Hello as being an
10306 array of a PAD type. The size of that PAD type is not statically
10307 known, but can be determined using a parallel XVZ variable.
10308 In that case, a copy of the PAD type with the correct size should
10309 be used for the fixed array.
10310
21649b50
JB
10311 3. ``Fixing'' record type objects:
10312 ----------------------------------
10313
10314 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10315 record types. In this case, in order to compute the associated
10316 fixed type, we need to determine the size and offset of each of
10317 its components. This, in turn, requires us to compute the fixed
10318 type of each of these components.
10319
10320 Consider for instance the example:
10321
10322 type Bounded_String (Max_Size : Natural) is record
10323 Str : String (1 .. Max_Size);
10324 Length : Natural;
10325 end record;
10326 My_String : Bounded_String (Max_Size => 10);
10327
10328 In that case, the position of field "Length" depends on the size
10329 of field Str, which itself depends on the value of the Max_Size
21649b50 10330 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10331 we need to fix the type of field Str. Therefore, fixing a variant
10332 record requires us to fix each of its components.
10333
10334 However, if a component does not have a dynamic size, the component
10335 should not be fixed. In particular, fields that use a PAD type
10336 should not fixed. Here is an example where this might happen
10337 (assuming type Rec above):
10338
10339 type Container (Big : Boolean) is record
10340 First : Rec;
10341 After : Integer;
10342 case Big is
10343 when True => Another : Integer;
10344 when False => null;
10345 end case;
10346 end record;
10347 My_Container : Container := (Big => False,
10348 First => (Empty => True),
10349 After => 42);
10350
10351 In that example, the compiler creates a PAD type for component First,
10352 whose size is constant, and then positions the component After just
10353 right after it. The offset of component After is therefore constant
10354 in this case.
10355
10356 The debugger computes the position of each field based on an algorithm
10357 that uses, among other things, the actual position and size of the field
21649b50
JB
10358 preceding it. Let's now imagine that the user is trying to print
10359 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10360 end up computing the offset of field After based on the size of the
10361 fixed version of field First. And since in our example First has
10362 only one actual field, the size of the fixed type is actually smaller
10363 than the amount of space allocated to that field, and thus we would
10364 compute the wrong offset of field After.
10365
21649b50
JB
10366 To make things more complicated, we need to watch out for dynamic
10367 components of variant records (identified by the ___XVL suffix in
10368 the component name). Even if the target type is a PAD type, the size
10369 of that type might not be statically known. So the PAD type needs
10370 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10371 we might end up with the wrong size for our component. This can be
10372 observed with the following type declarations:
284614f0
JB
10373
10374 type Octal is new Integer range 0 .. 7;
10375 type Octal_Array is array (Positive range <>) of Octal;
10376 pragma Pack (Octal_Array);
10377
10378 type Octal_Buffer (Size : Positive) is record
10379 Buffer : Octal_Array (1 .. Size);
10380 Length : Integer;
10381 end record;
10382
10383 In that case, Buffer is a PAD type whose size is unset and needs
10384 to be computed by fixing the unwrapped type.
10385
21649b50
JB
10386 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10387 ----------------------------------------------------------
10388
10389 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10390 thus far, be actually fixed?
10391
10392 The answer is: Only when referencing that element. For instance
10393 when selecting one component of a record, this specific component
10394 should be fixed at that point in time. Or when printing the value
10395 of a record, each component should be fixed before its value gets
10396 printed. Similarly for arrays, the element of the array should be
10397 fixed when printing each element of the array, or when extracting
10398 one element out of that array. On the other hand, fixing should
10399 not be performed on the elements when taking a slice of an array!
10400
10401 Note that one of the side-effects of miscomputing the offset and
10402 size of each field is that we end up also miscomputing the size
10403 of the containing type. This can have adverse results when computing
10404 the value of an entity. GDB fetches the value of an entity based
10405 on the size of its type, and thus a wrong size causes GDB to fetch
10406 the wrong amount of memory. In the case where the computed size is
10407 too small, GDB fetches too little data to print the value of our
10408 entiry. Results in this case as unpredicatble, as we usually read
10409 past the buffer containing the data =:-o. */
10410
10411/* Implement the evaluate_exp routine in the exp_descriptor structure
10412 for the Ada language. */
10413
52ce6436 10414static struct value *
ebf56fd3 10415ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10416 int *pos, enum noside noside)
14f9c5c9
AS
10417{
10418 enum exp_opcode op;
b5385fc0 10419 int tem;
14f9c5c9 10420 int pc;
5ec18f2b 10421 int preeval_pos;
14f9c5c9
AS
10422 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10423 struct type *type;
52ce6436 10424 int nargs, oplen;
d2e4a39e 10425 struct value **argvec;
14f9c5c9 10426
d2e4a39e
AS
10427 pc = *pos;
10428 *pos += 1;
14f9c5c9
AS
10429 op = exp->elts[pc].opcode;
10430
d2e4a39e 10431 switch (op)
14f9c5c9
AS
10432 {
10433 default:
10434 *pos -= 1;
6e48bd2c 10435 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10436
10437 if (noside == EVAL_NORMAL)
10438 arg1 = unwrap_value (arg1);
6e48bd2c
JB
10439
10440 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
10441 then we need to perform the conversion manually, because
10442 evaluate_subexp_standard doesn't do it. This conversion is
10443 necessary in Ada because the different kinds of float/fixed
10444 types in Ada have different representations.
10445
10446 Similarly, we need to perform the conversion from OP_LONG
10447 ourselves. */
10448 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
10449 arg1 = ada_value_cast (expect_type, arg1, noside);
10450
10451 return arg1;
4c4b4cd2
PH
10452
10453 case OP_STRING:
10454 {
76a01679 10455 struct value *result;
5b4ee69b 10456
76a01679
JB
10457 *pos -= 1;
10458 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10459 /* The result type will have code OP_STRING, bashed there from
10460 OP_ARRAY. Bash it back. */
df407dfe
AC
10461 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10462 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10463 return result;
4c4b4cd2 10464 }
14f9c5c9
AS
10465
10466 case UNOP_CAST:
10467 (*pos) += 2;
10468 type = exp->elts[pc + 1].type;
10469 arg1 = evaluate_subexp (type, exp, pos, noside);
10470 if (noside == EVAL_SKIP)
4c4b4cd2 10471 goto nosideret;
6e48bd2c 10472 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
10473 return arg1;
10474
4c4b4cd2
PH
10475 case UNOP_QUAL:
10476 (*pos) += 2;
10477 type = exp->elts[pc + 1].type;
10478 return ada_evaluate_subexp (type, exp, pos, noside);
10479
14f9c5c9
AS
10480 case BINOP_ASSIGN:
10481 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10482 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10483 {
10484 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10485 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10486 return arg1;
10487 return ada_value_assign (arg1, arg1);
10488 }
003f3813
JB
10489 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10490 except if the lhs of our assignment is a convenience variable.
10491 In the case of assigning to a convenience variable, the lhs
10492 should be exactly the result of the evaluation of the rhs. */
10493 type = value_type (arg1);
10494 if (VALUE_LVAL (arg1) == lval_internalvar)
10495 type = NULL;
10496 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10497 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10498 return arg1;
df407dfe
AC
10499 if (ada_is_fixed_point_type (value_type (arg1)))
10500 arg2 = cast_to_fixed (value_type (arg1), arg2);
10501 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10502 error
323e0a4a 10503 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10504 else
df407dfe 10505 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10506 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10507
10508 case BINOP_ADD:
10509 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10510 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10511 if (noside == EVAL_SKIP)
4c4b4cd2 10512 goto nosideret;
2ac8a782
JB
10513 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10514 return (value_from_longest
10515 (value_type (arg1),
10516 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10517 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10518 return (value_from_longest
10519 (value_type (arg2),
10520 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10521 if ((ada_is_fixed_point_type (value_type (arg1))
10522 || ada_is_fixed_point_type (value_type (arg2)))
10523 && value_type (arg1) != value_type (arg2))
323e0a4a 10524 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10525 /* Do the addition, and cast the result to the type of the first
10526 argument. We cannot cast the result to a reference type, so if
10527 ARG1 is a reference type, find its underlying type. */
10528 type = value_type (arg1);
10529 while (TYPE_CODE (type) == TYPE_CODE_REF)
10530 type = TYPE_TARGET_TYPE (type);
f44316fa 10531 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10532 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10533
10534 case BINOP_SUB:
10535 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10536 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10537 if (noside == EVAL_SKIP)
4c4b4cd2 10538 goto nosideret;
2ac8a782
JB
10539 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10540 return (value_from_longest
10541 (value_type (arg1),
10542 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10543 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10544 return (value_from_longest
10545 (value_type (arg2),
10546 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10547 if ((ada_is_fixed_point_type (value_type (arg1))
10548 || ada_is_fixed_point_type (value_type (arg2)))
10549 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10550 error (_("Operands of fixed-point subtraction "
10551 "must have the same type"));
b7789565
JB
10552 /* Do the substraction, and cast the result to the type of the first
10553 argument. We cannot cast the result to a reference type, so if
10554 ARG1 is a reference type, find its underlying type. */
10555 type = value_type (arg1);
10556 while (TYPE_CODE (type) == TYPE_CODE_REF)
10557 type = TYPE_TARGET_TYPE (type);
f44316fa 10558 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10559 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10560
10561 case BINOP_MUL:
10562 case BINOP_DIV:
e1578042
JB
10563 case BINOP_REM:
10564 case BINOP_MOD:
14f9c5c9
AS
10565 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10566 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10567 if (noside == EVAL_SKIP)
4c4b4cd2 10568 goto nosideret;
e1578042 10569 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10570 {
10571 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10572 return value_zero (value_type (arg1), not_lval);
10573 }
14f9c5c9 10574 else
4c4b4cd2 10575 {
a53b7a21 10576 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10577 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10578 arg1 = cast_from_fixed (type, arg1);
df407dfe 10579 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10580 arg2 = cast_from_fixed (type, arg2);
f44316fa 10581 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10582 return ada_value_binop (arg1, arg2, op);
10583 }
10584
4c4b4cd2
PH
10585 case BINOP_EQUAL:
10586 case BINOP_NOTEQUAL:
14f9c5c9 10587 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10588 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10589 if (noside == EVAL_SKIP)
76a01679 10590 goto nosideret;
4c4b4cd2 10591 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10592 tem = 0;
4c4b4cd2 10593 else
f44316fa
UW
10594 {
10595 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10596 tem = ada_value_equal (arg1, arg2);
10597 }
4c4b4cd2 10598 if (op == BINOP_NOTEQUAL)
76a01679 10599 tem = !tem;
fbb06eb1
UW
10600 type = language_bool_type (exp->language_defn, exp->gdbarch);
10601 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10602
10603 case UNOP_NEG:
10604 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10605 if (noside == EVAL_SKIP)
10606 goto nosideret;
df407dfe
AC
10607 else if (ada_is_fixed_point_type (value_type (arg1)))
10608 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10609 else
f44316fa
UW
10610 {
10611 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10612 return value_neg (arg1);
10613 }
4c4b4cd2 10614
2330c6c6
JB
10615 case BINOP_LOGICAL_AND:
10616 case BINOP_LOGICAL_OR:
10617 case UNOP_LOGICAL_NOT:
000d5124
JB
10618 {
10619 struct value *val;
10620
10621 *pos -= 1;
10622 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10623 type = language_bool_type (exp->language_defn, exp->gdbarch);
10624 return value_cast (type, val);
000d5124 10625 }
2330c6c6
JB
10626
10627 case BINOP_BITWISE_AND:
10628 case BINOP_BITWISE_IOR:
10629 case BINOP_BITWISE_XOR:
000d5124
JB
10630 {
10631 struct value *val;
10632
10633 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10634 *pos = pc;
10635 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10636
10637 return value_cast (value_type (arg1), val);
10638 }
2330c6c6 10639
14f9c5c9
AS
10640 case OP_VAR_VALUE:
10641 *pos -= 1;
6799def4 10642
14f9c5c9 10643 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10644 {
10645 *pos += 4;
10646 goto nosideret;
10647 }
da5c522f
JB
10648
10649 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10650 /* Only encountered when an unresolved symbol occurs in a
10651 context other than a function call, in which case, it is
52ce6436 10652 invalid. */
323e0a4a 10653 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10654 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10655
10656 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10657 {
0c1f74cf 10658 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10659 /* Check to see if this is a tagged type. We also need to handle
10660 the case where the type is a reference to a tagged type, but
10661 we have to be careful to exclude pointers to tagged types.
10662 The latter should be shown as usual (as a pointer), whereas
10663 a reference should mostly be transparent to the user. */
10664 if (ada_is_tagged_type (type, 0)
023db19c 10665 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10666 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10667 {
10668 /* Tagged types are a little special in the fact that the real
10669 type is dynamic and can only be determined by inspecting the
10670 object's tag. This means that we need to get the object's
10671 value first (EVAL_NORMAL) and then extract the actual object
10672 type from its tag.
10673
10674 Note that we cannot skip the final step where we extract
10675 the object type from its tag, because the EVAL_NORMAL phase
10676 results in dynamic components being resolved into fixed ones.
10677 This can cause problems when trying to print the type
10678 description of tagged types whose parent has a dynamic size:
10679 We use the type name of the "_parent" component in order
10680 to print the name of the ancestor type in the type description.
10681 If that component had a dynamic size, the resolution into
10682 a fixed type would result in the loss of that type name,
10683 thus preventing us from printing the name of the ancestor
10684 type in the type description. */
10685 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10686
10687 if (TYPE_CODE (type) != TYPE_CODE_REF)
10688 {
10689 struct type *actual_type;
10690
10691 actual_type = type_from_tag (ada_value_tag (arg1));
10692 if (actual_type == NULL)
10693 /* If, for some reason, we were unable to determine
10694 the actual type from the tag, then use the static
10695 approximation that we just computed as a fallback.
10696 This can happen if the debugging information is
10697 incomplete, for instance. */
10698 actual_type = type;
10699 return value_zero (actual_type, not_lval);
10700 }
10701 else
10702 {
10703 /* In the case of a ref, ada_coerce_ref takes care
10704 of determining the actual type. But the evaluation
10705 should return a ref as it should be valid to ask
10706 for its address; so rebuild a ref after coerce. */
10707 arg1 = ada_coerce_ref (arg1);
a65cfae5 10708 return value_ref (arg1, TYPE_CODE_REF);
0d72a7c3
JB
10709 }
10710 }
0c1f74cf 10711
84754697
JB
10712 /* Records and unions for which GNAT encodings have been
10713 generated need to be statically fixed as well.
10714 Otherwise, non-static fixing produces a type where
10715 all dynamic properties are removed, which prevents "ptype"
10716 from being able to completely describe the type.
10717 For instance, a case statement in a variant record would be
10718 replaced by the relevant components based on the actual
10719 value of the discriminants. */
10720 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10721 && dynamic_template_type (type) != NULL)
10722 || (TYPE_CODE (type) == TYPE_CODE_UNION
10723 && ada_find_parallel_type (type, "___XVU") != NULL))
10724 {
10725 *pos += 4;
10726 return value_zero (to_static_fixed_type (type), not_lval);
10727 }
4c4b4cd2 10728 }
da5c522f
JB
10729
10730 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10731 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10732
10733 case OP_FUNCALL:
10734 (*pos) += 2;
10735
10736 /* Allocate arg vector, including space for the function to be
10737 called in argvec[0] and a terminating NULL. */
10738 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8d749320 10739 argvec = XALLOCAVEC (struct value *, nargs + 2);
4c4b4cd2
PH
10740
10741 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10742 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10743 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10744 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10745 else
10746 {
10747 for (tem = 0; tem <= nargs; tem += 1)
10748 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10749 argvec[tem] = 0;
10750
10751 if (noside == EVAL_SKIP)
10752 goto nosideret;
10753 }
10754
ad82864c
JB
10755 if (ada_is_constrained_packed_array_type
10756 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10757 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10758 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10759 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10760 /* This is a packed array that has already been fixed, and
10761 therefore already coerced to a simple array. Nothing further
10762 to do. */
10763 ;
e6c2c623
PMR
10764 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10765 {
10766 /* Make sure we dereference references so that all the code below
10767 feels like it's really handling the referenced value. Wrapping
10768 types (for alignment) may be there, so make sure we strip them as
10769 well. */
10770 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10771 }
10772 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10773 && VALUE_LVAL (argvec[0]) == lval_memory)
10774 argvec[0] = value_addr (argvec[0]);
4c4b4cd2 10775
df407dfe 10776 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10777
10778 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10779 them. So, if this is an array typedef (encoding use for array
10780 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10781 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10782 type = ada_typedef_target_type (type);
10783
4c4b4cd2
PH
10784 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10785 {
61ee279c 10786 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10787 {
10788 case TYPE_CODE_FUNC:
61ee279c 10789 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10790 break;
10791 case TYPE_CODE_ARRAY:
10792 break;
10793 case TYPE_CODE_STRUCT:
10794 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10795 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10796 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10797 break;
10798 default:
323e0a4a 10799 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10800 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10801 break;
10802 }
10803 }
10804
10805 switch (TYPE_CODE (type))
10806 {
10807 case TYPE_CODE_FUNC:
10808 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10809 {
10810 struct type *rtype = TYPE_TARGET_TYPE (type);
10811
10812 if (TYPE_GNU_IFUNC (type))
10813 return allocate_value (TYPE_TARGET_TYPE (rtype));
10814 return allocate_value (rtype);
10815 }
4c4b4cd2 10816 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10817 case TYPE_CODE_INTERNAL_FUNCTION:
10818 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10819 /* We don't know anything about what the internal
10820 function might return, but we have to return
10821 something. */
10822 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10823 not_lval);
10824 else
10825 return call_internal_function (exp->gdbarch, exp->language_defn,
10826 argvec[0], nargs, argvec + 1);
10827
4c4b4cd2
PH
10828 case TYPE_CODE_STRUCT:
10829 {
10830 int arity;
10831
4c4b4cd2
PH
10832 arity = ada_array_arity (type);
10833 type = ada_array_element_type (type, nargs);
10834 if (type == NULL)
323e0a4a 10835 error (_("cannot subscript or call a record"));
4c4b4cd2 10836 if (arity != nargs)
323e0a4a 10837 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10838 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10839 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10840 return
10841 unwrap_value (ada_value_subscript
10842 (argvec[0], nargs, argvec + 1));
10843 }
10844 case TYPE_CODE_ARRAY:
10845 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10846 {
10847 type = ada_array_element_type (type, nargs);
10848 if (type == NULL)
323e0a4a 10849 error (_("element type of array unknown"));
4c4b4cd2 10850 else
0a07e705 10851 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10852 }
10853 return
10854 unwrap_value (ada_value_subscript
10855 (ada_coerce_to_simple_array (argvec[0]),
10856 nargs, argvec + 1));
10857 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10858 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10859 {
deede10c 10860 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10861 type = ada_array_element_type (type, nargs);
10862 if (type == NULL)
323e0a4a 10863 error (_("element type of array unknown"));
4c4b4cd2 10864 else
0a07e705 10865 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10866 }
10867 return
deede10c
JB
10868 unwrap_value (ada_value_ptr_subscript (argvec[0],
10869 nargs, argvec + 1));
4c4b4cd2
PH
10870
10871 default:
e1d5a0d2
PH
10872 error (_("Attempt to index or call something other than an "
10873 "array or function"));
4c4b4cd2
PH
10874 }
10875
10876 case TERNOP_SLICE:
10877 {
10878 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10879 struct value *low_bound_val =
10880 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10881 struct value *high_bound_val =
10882 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10883 LONGEST low_bound;
10884 LONGEST high_bound;
5b4ee69b 10885
994b9211
AC
10886 low_bound_val = coerce_ref (low_bound_val);
10887 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
10888 low_bound = value_as_long (low_bound_val);
10889 high_bound = value_as_long (high_bound_val);
963a6417 10890
4c4b4cd2
PH
10891 if (noside == EVAL_SKIP)
10892 goto nosideret;
10893
4c4b4cd2
PH
10894 /* If this is a reference to an aligner type, then remove all
10895 the aligners. */
df407dfe
AC
10896 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10897 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10898 TYPE_TARGET_TYPE (value_type (array)) =
10899 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10900
ad82864c 10901 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10902 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10903
10904 /* If this is a reference to an array or an array lvalue,
10905 convert to a pointer. */
df407dfe
AC
10906 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10907 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10908 && VALUE_LVAL (array) == lval_memory))
10909 array = value_addr (array);
10910
1265e4aa 10911 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10912 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10913 (value_type (array))))
0b5d8877 10914 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10915
10916 array = ada_coerce_to_simple_array_ptr (array);
10917
714e53ab
PH
10918 /* If we have more than one level of pointer indirection,
10919 dereference the value until we get only one level. */
df407dfe
AC
10920 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10921 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10922 == TYPE_CODE_PTR))
10923 array = value_ind (array);
10924
10925 /* Make sure we really do have an array type before going further,
10926 to avoid a SEGV when trying to get the index type or the target
10927 type later down the road if the debug info generated by
10928 the compiler is incorrect or incomplete. */
df407dfe 10929 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10930 error (_("cannot take slice of non-array"));
714e53ab 10931
828292f2
JB
10932 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10933 == TYPE_CODE_PTR)
4c4b4cd2 10934 {
828292f2
JB
10935 struct type *type0 = ada_check_typedef (value_type (array));
10936
0b5d8877 10937 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10938 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10939 else
10940 {
10941 struct type *arr_type0 =
828292f2 10942 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10943
f5938064
JG
10944 return ada_value_slice_from_ptr (array, arr_type0,
10945 longest_to_int (low_bound),
10946 longest_to_int (high_bound));
4c4b4cd2
PH
10947 }
10948 }
10949 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10950 return array;
10951 else if (high_bound < low_bound)
df407dfe 10952 return empty_array (value_type (array), low_bound);
4c4b4cd2 10953 else
529cad9c
PH
10954 return ada_value_slice (array, longest_to_int (low_bound),
10955 longest_to_int (high_bound));
4c4b4cd2 10956 }
14f9c5c9 10957
4c4b4cd2
PH
10958 case UNOP_IN_RANGE:
10959 (*pos) += 2;
10960 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10961 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10962
14f9c5c9 10963 if (noside == EVAL_SKIP)
4c4b4cd2 10964 goto nosideret;
14f9c5c9 10965
4c4b4cd2
PH
10966 switch (TYPE_CODE (type))
10967 {
10968 default:
e1d5a0d2
PH
10969 lim_warning (_("Membership test incompletely implemented; "
10970 "always returns true"));
fbb06eb1
UW
10971 type = language_bool_type (exp->language_defn, exp->gdbarch);
10972 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10973
10974 case TYPE_CODE_RANGE:
030b4912
UW
10975 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10976 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10977 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10978 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10979 type = language_bool_type (exp->language_defn, exp->gdbarch);
10980 return
10981 value_from_longest (type,
4c4b4cd2
PH
10982 (value_less (arg1, arg3)
10983 || value_equal (arg1, arg3))
10984 && (value_less (arg2, arg1)
10985 || value_equal (arg2, arg1)));
10986 }
10987
10988 case BINOP_IN_BOUNDS:
14f9c5c9 10989 (*pos) += 2;
4c4b4cd2
PH
10990 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10991 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10992
4c4b4cd2
PH
10993 if (noside == EVAL_SKIP)
10994 goto nosideret;
14f9c5c9 10995
4c4b4cd2 10996 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10997 {
10998 type = language_bool_type (exp->language_defn, exp->gdbarch);
10999 return value_zero (type, not_lval);
11000 }
14f9c5c9 11001
4c4b4cd2 11002 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 11003
1eea4ebd
UW
11004 type = ada_index_type (value_type (arg2), tem, "range");
11005 if (!type)
11006 type = value_type (arg1);
14f9c5c9 11007
1eea4ebd
UW
11008 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11009 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 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 TERNOP_IN_RANGE:
11022 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11023 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11024 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11025
11026 if (noside == EVAL_SKIP)
11027 goto nosideret;
11028
f44316fa
UW
11029 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11030 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 11031 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 11032 return
fbb06eb1 11033 value_from_longest (type,
4c4b4cd2
PH
11034 (value_less (arg1, arg3)
11035 || value_equal (arg1, arg3))
11036 && (value_less (arg2, arg1)
11037 || value_equal (arg2, arg1)));
11038
11039 case OP_ATR_FIRST:
11040 case OP_ATR_LAST:
11041 case OP_ATR_LENGTH:
11042 {
76a01679 11043 struct type *type_arg;
5b4ee69b 11044
76a01679
JB
11045 if (exp->elts[*pos].opcode == OP_TYPE)
11046 {
11047 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11048 arg1 = NULL;
5bc23cb3 11049 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
11050 }
11051 else
11052 {
11053 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11054 type_arg = NULL;
11055 }
11056
11057 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 11058 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
11059 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11060 *pos += 4;
11061
11062 if (noside == EVAL_SKIP)
11063 goto nosideret;
11064
11065 if (type_arg == NULL)
11066 {
11067 arg1 = ada_coerce_ref (arg1);
11068
ad82864c 11069 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
11070 arg1 = ada_coerce_to_simple_array (arg1);
11071
aa4fb036 11072 if (op == OP_ATR_LENGTH)
1eea4ebd 11073 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11074 else
11075 {
11076 type = ada_index_type (value_type (arg1), tem,
11077 ada_attribute_name (op));
11078 if (type == NULL)
11079 type = builtin_type (exp->gdbarch)->builtin_int;
11080 }
76a01679
JB
11081
11082 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 11083 return allocate_value (type);
76a01679
JB
11084
11085 switch (op)
11086 {
11087 default: /* Should never happen. */
323e0a4a 11088 error (_("unexpected attribute encountered"));
76a01679 11089 case OP_ATR_FIRST:
1eea4ebd
UW
11090 return value_from_longest
11091 (type, ada_array_bound (arg1, tem, 0));
76a01679 11092 case OP_ATR_LAST:
1eea4ebd
UW
11093 return value_from_longest
11094 (type, ada_array_bound (arg1, tem, 1));
76a01679 11095 case OP_ATR_LENGTH:
1eea4ebd
UW
11096 return value_from_longest
11097 (type, ada_array_length (arg1, tem));
76a01679
JB
11098 }
11099 }
11100 else if (discrete_type_p (type_arg))
11101 {
11102 struct type *range_type;
0d5cff50 11103 const char *name = ada_type_name (type_arg);
5b4ee69b 11104
76a01679
JB
11105 range_type = NULL;
11106 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 11107 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
11108 if (range_type == NULL)
11109 range_type = type_arg;
11110 switch (op)
11111 {
11112 default:
323e0a4a 11113 error (_("unexpected attribute encountered"));
76a01679 11114 case OP_ATR_FIRST:
690cc4eb 11115 return value_from_longest
43bbcdc2 11116 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 11117 case OP_ATR_LAST:
690cc4eb 11118 return value_from_longest
43bbcdc2 11119 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 11120 case OP_ATR_LENGTH:
323e0a4a 11121 error (_("the 'length attribute applies only to array types"));
76a01679
JB
11122 }
11123 }
11124 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 11125 error (_("unimplemented type attribute"));
76a01679
JB
11126 else
11127 {
11128 LONGEST low, high;
11129
ad82864c
JB
11130 if (ada_is_constrained_packed_array_type (type_arg))
11131 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 11132
aa4fb036 11133 if (op == OP_ATR_LENGTH)
1eea4ebd 11134 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
11135 else
11136 {
11137 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11138 if (type == NULL)
11139 type = builtin_type (exp->gdbarch)->builtin_int;
11140 }
1eea4ebd 11141
76a01679
JB
11142 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11143 return allocate_value (type);
11144
11145 switch (op)
11146 {
11147 default:
323e0a4a 11148 error (_("unexpected attribute encountered"));
76a01679 11149 case OP_ATR_FIRST:
1eea4ebd 11150 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
11151 return value_from_longest (type, low);
11152 case OP_ATR_LAST:
1eea4ebd 11153 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11154 return value_from_longest (type, high);
11155 case OP_ATR_LENGTH:
1eea4ebd
UW
11156 low = ada_array_bound_from_type (type_arg, tem, 0);
11157 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
11158 return value_from_longest (type, high - low + 1);
11159 }
11160 }
14f9c5c9
AS
11161 }
11162
4c4b4cd2
PH
11163 case OP_ATR_TAG:
11164 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11165 if (noside == EVAL_SKIP)
76a01679 11166 goto nosideret;
4c4b4cd2
PH
11167
11168 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11169 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
11170
11171 return ada_value_tag (arg1);
11172
11173 case OP_ATR_MIN:
11174 case OP_ATR_MAX:
11175 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11176 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11177 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11178 if (noside == EVAL_SKIP)
76a01679 11179 goto nosideret;
d2e4a39e 11180 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11181 return value_zero (value_type (arg1), not_lval);
14f9c5c9 11182 else
f44316fa
UW
11183 {
11184 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11185 return value_binop (arg1, arg2,
11186 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11187 }
14f9c5c9 11188
4c4b4cd2
PH
11189 case OP_ATR_MODULUS:
11190 {
31dedfee 11191 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 11192
5b4ee69b 11193 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
11194 if (noside == EVAL_SKIP)
11195 goto nosideret;
4c4b4cd2 11196
76a01679 11197 if (!ada_is_modular_type (type_arg))
323e0a4a 11198 error (_("'modulus must be applied to modular type"));
4c4b4cd2 11199
76a01679
JB
11200 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11201 ada_modulus (type_arg));
4c4b4cd2
PH
11202 }
11203
11204
11205 case OP_ATR_POS:
11206 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
11207 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11208 if (noside == EVAL_SKIP)
76a01679 11209 goto nosideret;
3cb382c9
UW
11210 type = builtin_type (exp->gdbarch)->builtin_int;
11211 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11212 return value_zero (type, not_lval);
14f9c5c9 11213 else
3cb382c9 11214 return value_pos_atr (type, arg1);
14f9c5c9 11215
4c4b4cd2
PH
11216 case OP_ATR_SIZE:
11217 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
11218 type = value_type (arg1);
11219
11220 /* If the argument is a reference, then dereference its type, since
11221 the user is really asking for the size of the actual object,
11222 not the size of the pointer. */
11223 if (TYPE_CODE (type) == TYPE_CODE_REF)
11224 type = TYPE_TARGET_TYPE (type);
11225
4c4b4cd2 11226 if (noside == EVAL_SKIP)
76a01679 11227 goto nosideret;
4c4b4cd2 11228 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 11229 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 11230 else
22601c15 11231 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 11232 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
11233
11234 case OP_ATR_VAL:
11235 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 11236 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11237 type = exp->elts[pc + 2].type;
14f9c5c9 11238 if (noside == EVAL_SKIP)
76a01679 11239 goto nosideret;
4c4b4cd2 11240 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11241 return value_zero (type, not_lval);
4c4b4cd2 11242 else
76a01679 11243 return value_val_atr (type, arg1);
4c4b4cd2
PH
11244
11245 case BINOP_EXP:
11246 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11247 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11248 if (noside == EVAL_SKIP)
11249 goto nosideret;
11250 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11251 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11252 else
f44316fa
UW
11253 {
11254 /* For integer exponentiation operations,
11255 only promote the first argument. */
11256 if (is_integral_type (value_type (arg2)))
11257 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11258 else
11259 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11260
11261 return value_binop (arg1, arg2, op);
11262 }
4c4b4cd2
PH
11263
11264 case UNOP_PLUS:
11265 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11266 if (noside == EVAL_SKIP)
11267 goto nosideret;
11268 else
11269 return arg1;
11270
11271 case UNOP_ABS:
11272 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11273 if (noside == EVAL_SKIP)
11274 goto nosideret;
f44316fa 11275 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11276 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11277 return value_neg (arg1);
14f9c5c9 11278 else
4c4b4cd2 11279 return arg1;
14f9c5c9
AS
11280
11281 case UNOP_IND:
5ec18f2b 11282 preeval_pos = *pos;
6b0d7253 11283 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11284 if (noside == EVAL_SKIP)
4c4b4cd2 11285 goto nosideret;
df407dfe 11286 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11287 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11288 {
11289 if (ada_is_array_descriptor_type (type))
11290 /* GDB allows dereferencing GNAT array descriptors. */
11291 {
11292 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11293
4c4b4cd2 11294 if (arrType == NULL)
323e0a4a 11295 error (_("Attempt to dereference null array pointer."));
00a4c844 11296 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11297 }
11298 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11299 || TYPE_CODE (type) == TYPE_CODE_REF
11300 /* In C you can dereference an array to get the 1st elt. */
11301 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11302 {
5ec18f2b
JG
11303 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11304 only be determined by inspecting the object's tag.
11305 This means that we need to evaluate completely the
11306 expression in order to get its type. */
11307
023db19c
JB
11308 if ((TYPE_CODE (type) == TYPE_CODE_REF
11309 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11310 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11311 {
11312 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11313 EVAL_NORMAL);
11314 type = value_type (ada_value_ind (arg1));
11315 }
11316 else
11317 {
11318 type = to_static_fixed_type
11319 (ada_aligned_type
11320 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11321 }
c1b5a1a6 11322 ada_ensure_varsize_limit (type);
714e53ab
PH
11323 return value_zero (type, lval_memory);
11324 }
4c4b4cd2 11325 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11326 {
11327 /* GDB allows dereferencing an int. */
11328 if (expect_type == NULL)
11329 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11330 lval_memory);
11331 else
11332 {
11333 expect_type =
11334 to_static_fixed_type (ada_aligned_type (expect_type));
11335 return value_zero (expect_type, lval_memory);
11336 }
11337 }
4c4b4cd2 11338 else
323e0a4a 11339 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11340 }
0963b4bd 11341 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11342 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11343
96967637
JB
11344 if (TYPE_CODE (type) == TYPE_CODE_INT)
11345 /* GDB allows dereferencing an int. If we were given
11346 the expect_type, then use that as the target type.
11347 Otherwise, assume that the target type is an int. */
11348 {
11349 if (expect_type != NULL)
11350 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11351 arg1));
11352 else
11353 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11354 (CORE_ADDR) value_as_address (arg1));
11355 }
6b0d7253 11356
4c4b4cd2
PH
11357 if (ada_is_array_descriptor_type (type))
11358 /* GDB allows dereferencing GNAT array descriptors. */
11359 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11360 else
4c4b4cd2 11361 return ada_value_ind (arg1);
14f9c5c9
AS
11362
11363 case STRUCTOP_STRUCT:
11364 tem = longest_to_int (exp->elts[pc + 1].longconst);
11365 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11366 preeval_pos = *pos;
14f9c5c9
AS
11367 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11368 if (noside == EVAL_SKIP)
4c4b4cd2 11369 goto nosideret;
14f9c5c9 11370 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11371 {
df407dfe 11372 struct type *type1 = value_type (arg1);
5b4ee69b 11373
76a01679
JB
11374 if (ada_is_tagged_type (type1, 1))
11375 {
11376 type = ada_lookup_struct_elt_type (type1,
11377 &exp->elts[pc + 2].string,
11378 1, 1, NULL);
5ec18f2b
JG
11379
11380 /* If the field is not found, check if it exists in the
11381 extension of this object's type. This means that we
11382 need to evaluate completely the expression. */
11383
76a01679 11384 if (type == NULL)
5ec18f2b
JG
11385 {
11386 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11387 EVAL_NORMAL);
11388 arg1 = ada_value_struct_elt (arg1,
11389 &exp->elts[pc + 2].string,
11390 0);
11391 arg1 = unwrap_value (arg1);
11392 type = value_type (ada_to_fixed_value (arg1));
11393 }
76a01679
JB
11394 }
11395 else
11396 type =
11397 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11398 0, NULL);
11399
11400 return value_zero (ada_aligned_type (type), lval_memory);
11401 }
14f9c5c9 11402 else
a579cd9a
MW
11403 {
11404 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11405 arg1 = unwrap_value (arg1);
11406 return ada_to_fixed_value (arg1);
11407 }
284614f0 11408
14f9c5c9 11409 case OP_TYPE:
4c4b4cd2
PH
11410 /* The value is not supposed to be used. This is here to make it
11411 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11412 (*pos) += 2;
11413 if (noside == EVAL_SKIP)
4c4b4cd2 11414 goto nosideret;
14f9c5c9 11415 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11416 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11417 else
323e0a4a 11418 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11419
11420 case OP_AGGREGATE:
11421 case OP_CHOICES:
11422 case OP_OTHERS:
11423 case OP_DISCRETE_RANGE:
11424 case OP_POSITIONAL:
11425 case OP_NAME:
11426 if (noside == EVAL_NORMAL)
11427 switch (op)
11428 {
11429 case OP_NAME:
11430 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11431 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11432 case OP_AGGREGATE:
11433 error (_("Aggregates only allowed on the right of an assignment"));
11434 default:
0963b4bd
MS
11435 internal_error (__FILE__, __LINE__,
11436 _("aggregate apparently mangled"));
52ce6436
PH
11437 }
11438
11439 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11440 *pos += oplen - 1;
11441 for (tem = 0; tem < nargs; tem += 1)
11442 ada_evaluate_subexp (NULL, exp, pos, noside);
11443 goto nosideret;
14f9c5c9
AS
11444 }
11445
11446nosideret:
22601c15 11447 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 11448}
14f9c5c9 11449\f
d2e4a39e 11450
4c4b4cd2 11451 /* Fixed point */
14f9c5c9
AS
11452
11453/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11454 type name that encodes the 'small and 'delta information.
4c4b4cd2 11455 Otherwise, return NULL. */
14f9c5c9 11456
d2e4a39e 11457static const char *
ebf56fd3 11458fixed_type_info (struct type *type)
14f9c5c9 11459{
d2e4a39e 11460 const char *name = ada_type_name (type);
14f9c5c9
AS
11461 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11462
d2e4a39e
AS
11463 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11464 {
14f9c5c9 11465 const char *tail = strstr (name, "___XF_");
5b4ee69b 11466
14f9c5c9 11467 if (tail == NULL)
4c4b4cd2 11468 return NULL;
d2e4a39e 11469 else
4c4b4cd2 11470 return tail + 5;
14f9c5c9
AS
11471 }
11472 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11473 return fixed_type_info (TYPE_TARGET_TYPE (type));
11474 else
11475 return NULL;
11476}
11477
4c4b4cd2 11478/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11479
11480int
ebf56fd3 11481ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11482{
11483 return fixed_type_info (type) != NULL;
11484}
11485
4c4b4cd2
PH
11486/* Return non-zero iff TYPE represents a System.Address type. */
11487
11488int
11489ada_is_system_address_type (struct type *type)
11490{
11491 return (TYPE_NAME (type)
11492 && strcmp (TYPE_NAME (type), "system__address") == 0);
11493}
11494
14f9c5c9
AS
11495/* Assuming that TYPE is the representation of an Ada fixed-point
11496 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 11497 delta cannot be determined. */
14f9c5c9
AS
11498
11499DOUBLEST
ebf56fd3 11500ada_delta (struct type *type)
14f9c5c9
AS
11501{
11502 const char *encoding = fixed_type_info (type);
facc390f 11503 DOUBLEST num, den;
14f9c5c9 11504
facc390f
JB
11505 /* Strictly speaking, num and den are encoded as integer. However,
11506 they may not fit into a long, and they will have to be converted
11507 to DOUBLEST anyway. So scan them as DOUBLEST. */
11508 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11509 &num, &den) < 2)
14f9c5c9 11510 return -1.0;
d2e4a39e 11511 else
facc390f 11512 return num / den;
14f9c5c9
AS
11513}
11514
11515/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11516 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
11517
11518static DOUBLEST
ebf56fd3 11519scaling_factor (struct type *type)
14f9c5c9
AS
11520{
11521 const char *encoding = fixed_type_info (type);
facc390f 11522 DOUBLEST num0, den0, num1, den1;
14f9c5c9 11523 int n;
d2e4a39e 11524
facc390f
JB
11525 /* Strictly speaking, num's and den's are encoded as integer. However,
11526 they may not fit into a long, and they will have to be converted
11527 to DOUBLEST anyway. So scan them as DOUBLEST. */
11528 n = sscanf (encoding,
11529 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
11530 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11531 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11532
11533 if (n < 2)
11534 return 1.0;
11535 else if (n == 4)
facc390f 11536 return num1 / den1;
d2e4a39e 11537 else
facc390f 11538 return num0 / den0;
14f9c5c9
AS
11539}
11540
11541
11542/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 11543 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
11544
11545DOUBLEST
ebf56fd3 11546ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 11547{
d2e4a39e 11548 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
11549}
11550
4c4b4cd2
PH
11551/* The representation of a fixed-point value of type TYPE
11552 corresponding to the value X. */
14f9c5c9
AS
11553
11554LONGEST
ebf56fd3 11555ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
11556{
11557 return (LONGEST) (x / scaling_factor (type) + 0.5);
11558}
11559
14f9c5c9 11560\f
d2e4a39e 11561
4c4b4cd2 11562 /* Range types */
14f9c5c9
AS
11563
11564/* Scan STR beginning at position K for a discriminant name, and
11565 return the value of that discriminant field of DVAL in *PX. If
11566 PNEW_K is not null, put the position of the character beyond the
11567 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11568 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11569
11570static int
108d56a4 11571scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
76a01679 11572 int *pnew_k)
14f9c5c9
AS
11573{
11574 static char *bound_buffer = NULL;
11575 static size_t bound_buffer_len = 0;
5da1a4d3 11576 const char *pstart, *pend, *bound;
d2e4a39e 11577 struct value *bound_val;
14f9c5c9
AS
11578
11579 if (dval == NULL || str == NULL || str[k] == '\0')
11580 return 0;
11581
5da1a4d3
SM
11582 pstart = str + k;
11583 pend = strstr (pstart, "__");
14f9c5c9
AS
11584 if (pend == NULL)
11585 {
5da1a4d3 11586 bound = pstart;
14f9c5c9
AS
11587 k += strlen (bound);
11588 }
d2e4a39e 11589 else
14f9c5c9 11590 {
5da1a4d3
SM
11591 int len = pend - pstart;
11592
11593 /* Strip __ and beyond. */
11594 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11595 strncpy (bound_buffer, pstart, len);
11596 bound_buffer[len] = '\0';
11597
14f9c5c9 11598 bound = bound_buffer;
d2e4a39e 11599 k = pend - str;
14f9c5c9 11600 }
d2e4a39e 11601
df407dfe 11602 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11603 if (bound_val == NULL)
11604 return 0;
11605
11606 *px = value_as_long (bound_val);
11607 if (pnew_k != NULL)
11608 *pnew_k = k;
11609 return 1;
11610}
11611
11612/* Value of variable named NAME in the current environment. If
11613 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11614 otherwise causes an error with message ERR_MSG. */
11615
d2e4a39e
AS
11616static struct value *
11617get_var_value (char *name, char *err_msg)
14f9c5c9 11618{
d12307c1 11619 struct block_symbol *syms;
14f9c5c9
AS
11620 int nsyms;
11621
4c4b4cd2 11622 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11623 &syms);
14f9c5c9
AS
11624
11625 if (nsyms != 1)
11626 {
11627 if (err_msg == NULL)
4c4b4cd2 11628 return 0;
14f9c5c9 11629 else
8a3fe4f8 11630 error (("%s"), err_msg);
14f9c5c9
AS
11631 }
11632
d12307c1 11633 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11634}
d2e4a39e 11635
14f9c5c9 11636/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
11637 no such variable found, returns 0, and sets *FLAG to 0. If
11638 successful, sets *FLAG to 1. */
11639
14f9c5c9 11640LONGEST
4c4b4cd2 11641get_int_var_value (char *name, int *flag)
14f9c5c9 11642{
4c4b4cd2 11643 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11644
14f9c5c9
AS
11645 if (var_val == 0)
11646 {
11647 if (flag != NULL)
4c4b4cd2 11648 *flag = 0;
14f9c5c9
AS
11649 return 0;
11650 }
11651 else
11652 {
11653 if (flag != NULL)
4c4b4cd2 11654 *flag = 1;
14f9c5c9
AS
11655 return value_as_long (var_val);
11656 }
11657}
d2e4a39e 11658
14f9c5c9
AS
11659
11660/* Return a range type whose base type is that of the range type named
11661 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11662 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11663 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11664 corresponding range type from debug information; fall back to using it
11665 if symbol lookup fails. If a new type must be created, allocate it
11666 like ORIG_TYPE was. The bounds information, in general, is encoded
11667 in NAME, the base type given in the named range type. */
14f9c5c9 11668
d2e4a39e 11669static struct type *
28c85d6c 11670to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11671{
0d5cff50 11672 const char *name;
14f9c5c9 11673 struct type *base_type;
108d56a4 11674 const char *subtype_info;
14f9c5c9 11675
28c85d6c
JB
11676 gdb_assert (raw_type != NULL);
11677 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11678
1ce677a4 11679 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11680 base_type = TYPE_TARGET_TYPE (raw_type);
11681 else
11682 base_type = raw_type;
11683
28c85d6c 11684 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11685 subtype_info = strstr (name, "___XD");
11686 if (subtype_info == NULL)
690cc4eb 11687 {
43bbcdc2
PH
11688 LONGEST L = ada_discrete_type_low_bound (raw_type);
11689 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11690
690cc4eb
PH
11691 if (L < INT_MIN || U > INT_MAX)
11692 return raw_type;
11693 else
0c9c3474
SA
11694 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11695 L, U);
690cc4eb 11696 }
14f9c5c9
AS
11697 else
11698 {
11699 static char *name_buf = NULL;
11700 static size_t name_len = 0;
11701 int prefix_len = subtype_info - name;
11702 LONGEST L, U;
11703 struct type *type;
108d56a4 11704 const char *bounds_str;
14f9c5c9
AS
11705 int n;
11706
11707 GROW_VECT (name_buf, name_len, prefix_len + 5);
11708 strncpy (name_buf, name, prefix_len);
11709 name_buf[prefix_len] = '\0';
11710
11711 subtype_info += 5;
11712 bounds_str = strchr (subtype_info, '_');
11713 n = 1;
11714
d2e4a39e 11715 if (*subtype_info == 'L')
4c4b4cd2
PH
11716 {
11717 if (!ada_scan_number (bounds_str, n, &L, &n)
11718 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11719 return raw_type;
11720 if (bounds_str[n] == '_')
11721 n += 2;
0963b4bd 11722 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11723 n += 1;
11724 subtype_info += 1;
11725 }
d2e4a39e 11726 else
4c4b4cd2
PH
11727 {
11728 int ok;
5b4ee69b 11729
4c4b4cd2
PH
11730 strcpy (name_buf + prefix_len, "___L");
11731 L = get_int_var_value (name_buf, &ok);
11732 if (!ok)
11733 {
323e0a4a 11734 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11735 L = 1;
11736 }
11737 }
14f9c5c9 11738
d2e4a39e 11739 if (*subtype_info == 'U')
4c4b4cd2
PH
11740 {
11741 if (!ada_scan_number (bounds_str, n, &U, &n)
11742 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11743 return raw_type;
11744 }
d2e4a39e 11745 else
4c4b4cd2
PH
11746 {
11747 int ok;
5b4ee69b 11748
4c4b4cd2
PH
11749 strcpy (name_buf + prefix_len, "___U");
11750 U = get_int_var_value (name_buf, &ok);
11751 if (!ok)
11752 {
323e0a4a 11753 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11754 U = L;
11755 }
11756 }
14f9c5c9 11757
0c9c3474
SA
11758 type = create_static_range_type (alloc_type_copy (raw_type),
11759 base_type, L, U);
d2e4a39e 11760 TYPE_NAME (type) = name;
14f9c5c9
AS
11761 return type;
11762 }
11763}
11764
4c4b4cd2
PH
11765/* True iff NAME is the name of a range type. */
11766
14f9c5c9 11767int
d2e4a39e 11768ada_is_range_type_name (const char *name)
14f9c5c9
AS
11769{
11770 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11771}
14f9c5c9 11772\f
d2e4a39e 11773
4c4b4cd2
PH
11774 /* Modular types */
11775
11776/* True iff TYPE is an Ada modular type. */
14f9c5c9 11777
14f9c5c9 11778int
d2e4a39e 11779ada_is_modular_type (struct type *type)
14f9c5c9 11780{
18af8284 11781 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11782
11783 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11784 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11785 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11786}
11787
4c4b4cd2
PH
11788/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11789
61ee279c 11790ULONGEST
0056e4d5 11791ada_modulus (struct type *type)
14f9c5c9 11792{
43bbcdc2 11793 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11794}
d2e4a39e 11795\f
f7f9143b
JB
11796
11797/* Ada exception catchpoint support:
11798 ---------------------------------
11799
11800 We support 3 kinds of exception catchpoints:
11801 . catchpoints on Ada exceptions
11802 . catchpoints on unhandled Ada exceptions
11803 . catchpoints on failed assertions
11804
11805 Exceptions raised during failed assertions, or unhandled exceptions
11806 could perfectly be caught with the general catchpoint on Ada exceptions.
11807 However, we can easily differentiate these two special cases, and having
11808 the option to distinguish these two cases from the rest can be useful
11809 to zero-in on certain situations.
11810
11811 Exception catchpoints are a specialized form of breakpoint,
11812 since they rely on inserting breakpoints inside known routines
11813 of the GNAT runtime. The implementation therefore uses a standard
11814 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11815 of breakpoint_ops.
11816
0259addd
JB
11817 Support in the runtime for exception catchpoints have been changed
11818 a few times already, and these changes affect the implementation
11819 of these catchpoints. In order to be able to support several
11820 variants of the runtime, we use a sniffer that will determine
28010a5d 11821 the runtime variant used by the program being debugged. */
f7f9143b 11822
82eacd52
JB
11823/* Ada's standard exceptions.
11824
11825 The Ada 83 standard also defined Numeric_Error. But there so many
11826 situations where it was unclear from the Ada 83 Reference Manual
11827 (RM) whether Constraint_Error or Numeric_Error should be raised,
11828 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11829 Interpretation saying that anytime the RM says that Numeric_Error
11830 should be raised, the implementation may raise Constraint_Error.
11831 Ada 95 went one step further and pretty much removed Numeric_Error
11832 from the list of standard exceptions (it made it a renaming of
11833 Constraint_Error, to help preserve compatibility when compiling
11834 an Ada83 compiler). As such, we do not include Numeric_Error from
11835 this list of standard exceptions. */
3d0b0fa3 11836
a121b7c1 11837static const char *standard_exc[] = {
3d0b0fa3
JB
11838 "constraint_error",
11839 "program_error",
11840 "storage_error",
11841 "tasking_error"
11842};
11843
0259addd
JB
11844typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11845
11846/* A structure that describes how to support exception catchpoints
11847 for a given executable. */
11848
11849struct exception_support_info
11850{
11851 /* The name of the symbol to break on in order to insert
11852 a catchpoint on exceptions. */
11853 const char *catch_exception_sym;
11854
11855 /* The name of the symbol to break on in order to insert
11856 a catchpoint on unhandled exceptions. */
11857 const char *catch_exception_unhandled_sym;
11858
11859 /* The name of the symbol to break on in order to insert
11860 a catchpoint on failed assertions. */
11861 const char *catch_assert_sym;
11862
11863 /* Assuming that the inferior just triggered an unhandled exception
11864 catchpoint, this function is responsible for returning the address
11865 in inferior memory where the name of that exception is stored.
11866 Return zero if the address could not be computed. */
11867 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11868};
11869
11870static CORE_ADDR ada_unhandled_exception_name_addr (void);
11871static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11872
11873/* The following exception support info structure describes how to
11874 implement exception catchpoints with the latest version of the
11875 Ada runtime (as of 2007-03-06). */
11876
11877static const struct exception_support_info default_exception_support_info =
11878{
11879 "__gnat_debug_raise_exception", /* catch_exception_sym */
11880 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11881 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11882 ada_unhandled_exception_name_addr
11883};
11884
11885/* The following exception support info structure describes how to
11886 implement exception catchpoints with a slightly older version
11887 of the Ada runtime. */
11888
11889static const struct exception_support_info exception_support_info_fallback =
11890{
11891 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11892 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11893 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11894 ada_unhandled_exception_name_addr_from_raise
11895};
11896
f17011e0
JB
11897/* Return nonzero if we can detect the exception support routines
11898 described in EINFO.
11899
11900 This function errors out if an abnormal situation is detected
11901 (for instance, if we find the exception support routines, but
11902 that support is found to be incomplete). */
11903
11904static int
11905ada_has_this_exception_support (const struct exception_support_info *einfo)
11906{
11907 struct symbol *sym;
11908
11909 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11910 that should be compiled with debugging information. As a result, we
11911 expect to find that symbol in the symtabs. */
11912
11913 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11914 if (sym == NULL)
a6af7abe
JB
11915 {
11916 /* Perhaps we did not find our symbol because the Ada runtime was
11917 compiled without debugging info, or simply stripped of it.
11918 It happens on some GNU/Linux distributions for instance, where
11919 users have to install a separate debug package in order to get
11920 the runtime's debugging info. In that situation, let the user
11921 know why we cannot insert an Ada exception catchpoint.
11922
11923 Note: Just for the purpose of inserting our Ada exception
11924 catchpoint, we could rely purely on the associated minimal symbol.
11925 But we would be operating in degraded mode anyway, since we are
11926 still lacking the debugging info needed later on to extract
11927 the name of the exception being raised (this name is printed in
11928 the catchpoint message, and is also used when trying to catch
11929 a specific exception). We do not handle this case for now. */
3b7344d5 11930 struct bound_minimal_symbol msym
1c8e84b0
JB
11931 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11932
3b7344d5 11933 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11934 error (_("Your Ada runtime appears to be missing some debugging "
11935 "information.\nCannot insert Ada exception catchpoint "
11936 "in this configuration."));
11937
11938 return 0;
11939 }
f17011e0
JB
11940
11941 /* Make sure that the symbol we found corresponds to a function. */
11942
11943 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11944 error (_("Symbol \"%s\" is not a function (class = %d)"),
11945 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11946
11947 return 1;
11948}
11949
0259addd
JB
11950/* Inspect the Ada runtime and determine which exception info structure
11951 should be used to provide support for exception catchpoints.
11952
3eecfa55
JB
11953 This function will always set the per-inferior exception_info,
11954 or raise an error. */
0259addd
JB
11955
11956static void
11957ada_exception_support_info_sniffer (void)
11958{
3eecfa55 11959 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11960
11961 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11962 if (data->exception_info != NULL)
0259addd
JB
11963 return;
11964
11965 /* Check the latest (default) exception support info. */
f17011e0 11966 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11967 {
3eecfa55 11968 data->exception_info = &default_exception_support_info;
0259addd
JB
11969 return;
11970 }
11971
11972 /* Try our fallback exception suport info. */
f17011e0 11973 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11974 {
3eecfa55 11975 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11976 return;
11977 }
11978
11979 /* Sometimes, it is normal for us to not be able to find the routine
11980 we are looking for. This happens when the program is linked with
11981 the shared version of the GNAT runtime, and the program has not been
11982 started yet. Inform the user of these two possible causes if
11983 applicable. */
11984
ccefe4c4 11985 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11986 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11987
11988 /* If the symbol does not exist, then check that the program is
11989 already started, to make sure that shared libraries have been
11990 loaded. If it is not started, this may mean that the symbol is
11991 in a shared library. */
11992
11993 if (ptid_get_pid (inferior_ptid) == 0)
11994 error (_("Unable to insert catchpoint. Try to start the program first."));
11995
11996 /* At this point, we know that we are debugging an Ada program and
11997 that the inferior has been started, but we still are not able to
0963b4bd 11998 find the run-time symbols. That can mean that we are in
0259addd
JB
11999 configurable run time mode, or that a-except as been optimized
12000 out by the linker... In any case, at this point it is not worth
12001 supporting this feature. */
12002
7dda8cff 12003 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
12004}
12005
f7f9143b
JB
12006/* True iff FRAME is very likely to be that of a function that is
12007 part of the runtime system. This is all very heuristic, but is
12008 intended to be used as advice as to what frames are uninteresting
12009 to most users. */
12010
12011static int
12012is_known_support_routine (struct frame_info *frame)
12013{
4ed6b5be 12014 struct symtab_and_line sal;
55b87a52 12015 char *func_name;
692465f1 12016 enum language func_lang;
f7f9143b 12017 int i;
f35a17b5 12018 const char *fullname;
f7f9143b 12019
4ed6b5be
JB
12020 /* If this code does not have any debugging information (no symtab),
12021 This cannot be any user code. */
f7f9143b 12022
4ed6b5be 12023 find_frame_sal (frame, &sal);
f7f9143b
JB
12024 if (sal.symtab == NULL)
12025 return 1;
12026
4ed6b5be
JB
12027 /* If there is a symtab, but the associated source file cannot be
12028 located, then assume this is not user code: Selecting a frame
12029 for which we cannot display the code would not be very helpful
12030 for the user. This should also take care of case such as VxWorks
12031 where the kernel has some debugging info provided for a few units. */
f7f9143b 12032
f35a17b5
JK
12033 fullname = symtab_to_fullname (sal.symtab);
12034 if (access (fullname, R_OK) != 0)
f7f9143b
JB
12035 return 1;
12036
4ed6b5be
JB
12037 /* Check the unit filename againt the Ada runtime file naming.
12038 We also check the name of the objfile against the name of some
12039 known system libraries that sometimes come with debugging info
12040 too. */
12041
f7f9143b
JB
12042 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12043 {
12044 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 12045 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 12046 return 1;
eb822aa6
DE
12047 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12048 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 12049 return 1;
f7f9143b
JB
12050 }
12051
4ed6b5be 12052 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 12053
e9e07ba6 12054 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
12055 if (func_name == NULL)
12056 return 1;
12057
12058 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12059 {
12060 re_comp (known_auxiliary_function_name_patterns[i]);
12061 if (re_exec (func_name))
55b87a52
KS
12062 {
12063 xfree (func_name);
12064 return 1;
12065 }
f7f9143b
JB
12066 }
12067
55b87a52 12068 xfree (func_name);
f7f9143b
JB
12069 return 0;
12070}
12071
12072/* Find the first frame that contains debugging information and that is not
12073 part of the Ada run-time, starting from FI and moving upward. */
12074
0ef643c8 12075void
f7f9143b
JB
12076ada_find_printable_frame (struct frame_info *fi)
12077{
12078 for (; fi != NULL; fi = get_prev_frame (fi))
12079 {
12080 if (!is_known_support_routine (fi))
12081 {
12082 select_frame (fi);
12083 break;
12084 }
12085 }
12086
12087}
12088
12089/* Assuming that the inferior just triggered an unhandled exception
12090 catchpoint, return the address in inferior memory where the name
12091 of the exception is stored.
12092
12093 Return zero if the address could not be computed. */
12094
12095static CORE_ADDR
12096ada_unhandled_exception_name_addr (void)
0259addd
JB
12097{
12098 return parse_and_eval_address ("e.full_name");
12099}
12100
12101/* Same as ada_unhandled_exception_name_addr, except that this function
12102 should be used when the inferior uses an older version of the runtime,
12103 where the exception name needs to be extracted from a specific frame
12104 several frames up in the callstack. */
12105
12106static CORE_ADDR
12107ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
12108{
12109 int frame_level;
12110 struct frame_info *fi;
3eecfa55 12111 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 12112 struct cleanup *old_chain;
f7f9143b
JB
12113
12114 /* To determine the name of this exception, we need to select
12115 the frame corresponding to RAISE_SYM_NAME. This frame is
12116 at least 3 levels up, so we simply skip the first 3 frames
12117 without checking the name of their associated function. */
12118 fi = get_current_frame ();
12119 for (frame_level = 0; frame_level < 3; frame_level += 1)
12120 if (fi != NULL)
12121 fi = get_prev_frame (fi);
12122
55b87a52 12123 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
12124 while (fi != NULL)
12125 {
55b87a52 12126 char *func_name;
692465f1
JB
12127 enum language func_lang;
12128
e9e07ba6 12129 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
12130 if (func_name != NULL)
12131 {
12132 make_cleanup (xfree, func_name);
12133
12134 if (strcmp (func_name,
12135 data->exception_info->catch_exception_sym) == 0)
12136 break; /* We found the frame we were looking for... */
12137 fi = get_prev_frame (fi);
12138 }
f7f9143b 12139 }
55b87a52 12140 do_cleanups (old_chain);
f7f9143b
JB
12141
12142 if (fi == NULL)
12143 return 0;
12144
12145 select_frame (fi);
12146 return parse_and_eval_address ("id.full_name");
12147}
12148
12149/* Assuming the inferior just triggered an Ada exception catchpoint
12150 (of any type), return the address in inferior memory where the name
12151 of the exception is stored, if applicable.
12152
45db7c09
PA
12153 Assumes the selected frame is the current frame.
12154
f7f9143b
JB
12155 Return zero if the address could not be computed, or if not relevant. */
12156
12157static CORE_ADDR
761269c8 12158ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12159 struct breakpoint *b)
12160{
3eecfa55
JB
12161 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12162
f7f9143b
JB
12163 switch (ex)
12164 {
761269c8 12165 case ada_catch_exception:
f7f9143b
JB
12166 return (parse_and_eval_address ("e.full_name"));
12167 break;
12168
761269c8 12169 case ada_catch_exception_unhandled:
3eecfa55 12170 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
12171 break;
12172
761269c8 12173 case ada_catch_assert:
f7f9143b
JB
12174 return 0; /* Exception name is not relevant in this case. */
12175 break;
12176
12177 default:
12178 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12179 break;
12180 }
12181
12182 return 0; /* Should never be reached. */
12183}
12184
12185/* Same as ada_exception_name_addr_1, except that it intercepts and contains
12186 any error that ada_exception_name_addr_1 might cause to be thrown.
12187 When an error is intercepted, a warning with the error message is printed,
12188 and zero is returned. */
12189
12190static CORE_ADDR
761269c8 12191ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12192 struct breakpoint *b)
12193{
f7f9143b
JB
12194 CORE_ADDR result = 0;
12195
492d29ea 12196 TRY
f7f9143b
JB
12197 {
12198 result = ada_exception_name_addr_1 (ex, b);
12199 }
12200
492d29ea 12201 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
12202 {
12203 warning (_("failed to get exception name: %s"), e.message);
12204 return 0;
12205 }
492d29ea 12206 END_CATCH
f7f9143b
JB
12207
12208 return result;
12209}
12210
28010a5d
PA
12211static char *ada_exception_catchpoint_cond_string (const char *excep_string);
12212
12213/* Ada catchpoints.
12214
12215 In the case of catchpoints on Ada exceptions, the catchpoint will
12216 stop the target on every exception the program throws. When a user
12217 specifies the name of a specific exception, we translate this
12218 request into a condition expression (in text form), and then parse
12219 it into an expression stored in each of the catchpoint's locations.
12220 We then use this condition to check whether the exception that was
12221 raised is the one the user is interested in. If not, then the
12222 target is resumed again. We store the name of the requested
12223 exception, in order to be able to re-set the condition expression
12224 when symbols change. */
12225
12226/* An instance of this type is used to represent an Ada catchpoint
5625a286 12227 breakpoint location. */
28010a5d 12228
5625a286 12229class ada_catchpoint_location : public bp_location
28010a5d 12230{
5625a286
PA
12231public:
12232 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12233 : bp_location (ops, owner)
12234 {}
28010a5d
PA
12235
12236 /* The condition that checks whether the exception that was raised
12237 is the specific exception the user specified on catchpoint
12238 creation. */
4d01a485 12239 expression_up excep_cond_expr;
28010a5d
PA
12240};
12241
12242/* Implement the DTOR method in the bp_location_ops structure for all
12243 Ada exception catchpoint kinds. */
12244
12245static void
12246ada_catchpoint_location_dtor (struct bp_location *bl)
12247{
12248 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12249
4d01a485 12250 al->excep_cond_expr.reset ();
28010a5d
PA
12251}
12252
12253/* The vtable to be used in Ada catchpoint locations. */
12254
12255static const struct bp_location_ops ada_catchpoint_location_ops =
12256{
12257 ada_catchpoint_location_dtor
12258};
12259
c1fc2657 12260/* An instance of this type is used to represent an Ada catchpoint. */
28010a5d 12261
c1fc2657 12262struct ada_catchpoint : public breakpoint
28010a5d 12263{
c1fc2657 12264 ~ada_catchpoint () override;
28010a5d
PA
12265
12266 /* The name of the specific exception the user specified. */
12267 char *excep_string;
12268};
12269
12270/* Parse the exception condition string in the context of each of the
12271 catchpoint's locations, and store them for later evaluation. */
12272
12273static void
12274create_excep_cond_exprs (struct ada_catchpoint *c)
12275{
12276 struct cleanup *old_chain;
12277 struct bp_location *bl;
12278 char *cond_string;
12279
12280 /* Nothing to do if there's no specific exception to catch. */
12281 if (c->excep_string == NULL)
12282 return;
12283
12284 /* Same if there are no locations... */
c1fc2657 12285 if (c->loc == NULL)
28010a5d
PA
12286 return;
12287
12288 /* Compute the condition expression in text form, from the specific
12289 expection we want to catch. */
12290 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
12291 old_chain = make_cleanup (xfree, cond_string);
12292
12293 /* Iterate over all the catchpoint's locations, and parse an
12294 expression for each. */
c1fc2657 12295 for (bl = c->loc; bl != NULL; bl = bl->next)
28010a5d
PA
12296 {
12297 struct ada_catchpoint_location *ada_loc
12298 = (struct ada_catchpoint_location *) bl;
4d01a485 12299 expression_up exp;
28010a5d
PA
12300
12301 if (!bl->shlib_disabled)
12302 {
bbc13ae3 12303 const char *s;
28010a5d
PA
12304
12305 s = cond_string;
492d29ea 12306 TRY
28010a5d 12307 {
036e657b
JB
12308 exp = parse_exp_1 (&s, bl->address,
12309 block_for_pc (bl->address),
12310 0);
28010a5d 12311 }
492d29ea 12312 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12313 {
12314 warning (_("failed to reevaluate internal exception condition "
12315 "for catchpoint %d: %s"),
c1fc2657 12316 c->number, e.message);
849f2b52 12317 }
492d29ea 12318 END_CATCH
28010a5d
PA
12319 }
12320
b22e99fd 12321 ada_loc->excep_cond_expr = std::move (exp);
28010a5d
PA
12322 }
12323
12324 do_cleanups (old_chain);
12325}
12326
c1fc2657 12327/* ada_catchpoint destructor. */
28010a5d 12328
c1fc2657 12329ada_catchpoint::~ada_catchpoint ()
28010a5d 12330{
c1fc2657 12331 xfree (this->excep_string);
28010a5d
PA
12332}
12333
12334/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12335 structure for all exception catchpoint kinds. */
12336
12337static struct bp_location *
761269c8 12338allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12339 struct breakpoint *self)
12340{
5625a286 12341 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
28010a5d
PA
12342}
12343
12344/* Implement the RE_SET method in the breakpoint_ops structure for all
12345 exception catchpoint kinds. */
12346
12347static void
761269c8 12348re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12349{
12350 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12351
12352 /* Call the base class's method. This updates the catchpoint's
12353 locations. */
2060206e 12354 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12355
12356 /* Reparse the exception conditional expressions. One for each
12357 location. */
12358 create_excep_cond_exprs (c);
12359}
12360
12361/* Returns true if we should stop for this breakpoint hit. If the
12362 user specified a specific exception, we only want to cause a stop
12363 if the program thrown that exception. */
12364
12365static int
12366should_stop_exception (const struct bp_location *bl)
12367{
12368 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12369 const struct ada_catchpoint_location *ada_loc
12370 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12371 int stop;
12372
12373 /* With no specific exception, should always stop. */
12374 if (c->excep_string == NULL)
12375 return 1;
12376
12377 if (ada_loc->excep_cond_expr == NULL)
12378 {
12379 /* We will have a NULL expression if back when we were creating
12380 the expressions, this location's had failed to parse. */
12381 return 1;
12382 }
12383
12384 stop = 1;
492d29ea 12385 TRY
28010a5d
PA
12386 {
12387 struct value *mark;
12388
12389 mark = value_mark ();
4d01a485 12390 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
28010a5d
PA
12391 value_free_to_mark (mark);
12392 }
492d29ea
PA
12393 CATCH (ex, RETURN_MASK_ALL)
12394 {
12395 exception_fprintf (gdb_stderr, ex,
12396 _("Error in testing exception condition:\n"));
12397 }
12398 END_CATCH
12399
28010a5d
PA
12400 return stop;
12401}
12402
12403/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12404 for all exception catchpoint kinds. */
12405
12406static void
761269c8 12407check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12408{
12409 bs->stop = should_stop_exception (bs->bp_location_at);
12410}
12411
f7f9143b
JB
12412/* Implement the PRINT_IT method in the breakpoint_ops structure
12413 for all exception catchpoint kinds. */
12414
12415static enum print_stop_action
761269c8 12416print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12417{
79a45e25 12418 struct ui_out *uiout = current_uiout;
348d480f
PA
12419 struct breakpoint *b = bs->breakpoint_at;
12420
956a9fb9 12421 annotate_catchpoint (b->number);
f7f9143b 12422
112e8700 12423 if (uiout->is_mi_like_p ())
f7f9143b 12424 {
112e8700 12425 uiout->field_string ("reason",
956a9fb9 12426 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
112e8700 12427 uiout->field_string ("disp", bpdisp_text (b->disposition));
f7f9143b
JB
12428 }
12429
112e8700
SM
12430 uiout->text (b->disposition == disp_del
12431 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12432 uiout->field_int ("bkptno", b->number);
12433 uiout->text (", ");
f7f9143b 12434
45db7c09
PA
12435 /* ada_exception_name_addr relies on the selected frame being the
12436 current frame. Need to do this here because this function may be
12437 called more than once when printing a stop, and below, we'll
12438 select the first frame past the Ada run-time (see
12439 ada_find_printable_frame). */
12440 select_frame (get_current_frame ());
12441
f7f9143b
JB
12442 switch (ex)
12443 {
761269c8
JB
12444 case ada_catch_exception:
12445 case ada_catch_exception_unhandled:
956a9fb9
JB
12446 {
12447 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12448 char exception_name[256];
12449
12450 if (addr != 0)
12451 {
c714b426
PA
12452 read_memory (addr, (gdb_byte *) exception_name,
12453 sizeof (exception_name) - 1);
956a9fb9
JB
12454 exception_name [sizeof (exception_name) - 1] = '\0';
12455 }
12456 else
12457 {
12458 /* For some reason, we were unable to read the exception
12459 name. This could happen if the Runtime was compiled
12460 without debugging info, for instance. In that case,
12461 just replace the exception name by the generic string
12462 "exception" - it will read as "an exception" in the
12463 notification we are about to print. */
967cff16 12464 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12465 }
12466 /* In the case of unhandled exception breakpoints, we print
12467 the exception name as "unhandled EXCEPTION_NAME", to make
12468 it clearer to the user which kind of catchpoint just got
12469 hit. We used ui_out_text to make sure that this extra
12470 info does not pollute the exception name in the MI case. */
761269c8 12471 if (ex == ada_catch_exception_unhandled)
112e8700
SM
12472 uiout->text ("unhandled ");
12473 uiout->field_string ("exception-name", exception_name);
956a9fb9
JB
12474 }
12475 break;
761269c8 12476 case ada_catch_assert:
956a9fb9
JB
12477 /* In this case, the name of the exception is not really
12478 important. Just print "failed assertion" to make it clearer
12479 that his program just hit an assertion-failure catchpoint.
12480 We used ui_out_text because this info does not belong in
12481 the MI output. */
112e8700 12482 uiout->text ("failed assertion");
956a9fb9 12483 break;
f7f9143b 12484 }
112e8700 12485 uiout->text (" at ");
956a9fb9 12486 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12487
12488 return PRINT_SRC_AND_LOC;
12489}
12490
12491/* Implement the PRINT_ONE method in the breakpoint_ops structure
12492 for all exception catchpoint kinds. */
12493
12494static void
761269c8 12495print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12496 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12497{
79a45e25 12498 struct ui_out *uiout = current_uiout;
28010a5d 12499 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12500 struct value_print_options opts;
12501
12502 get_user_print_options (&opts);
12503 if (opts.addressprint)
f7f9143b
JB
12504 {
12505 annotate_field (4);
112e8700 12506 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12507 }
12508
12509 annotate_field (5);
a6d9a66e 12510 *last_loc = b->loc;
f7f9143b
JB
12511 switch (ex)
12512 {
761269c8 12513 case ada_catch_exception:
28010a5d 12514 if (c->excep_string != NULL)
f7f9143b 12515 {
28010a5d
PA
12516 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12517
112e8700 12518 uiout->field_string ("what", msg);
f7f9143b
JB
12519 xfree (msg);
12520 }
12521 else
112e8700 12522 uiout->field_string ("what", "all Ada exceptions");
f7f9143b
JB
12523
12524 break;
12525
761269c8 12526 case ada_catch_exception_unhandled:
112e8700 12527 uiout->field_string ("what", "unhandled Ada exceptions");
f7f9143b
JB
12528 break;
12529
761269c8 12530 case ada_catch_assert:
112e8700 12531 uiout->field_string ("what", "failed Ada assertions");
f7f9143b
JB
12532 break;
12533
12534 default:
12535 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12536 break;
12537 }
12538}
12539
12540/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12541 for all exception catchpoint kinds. */
12542
12543static void
761269c8 12544print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12545 struct breakpoint *b)
12546{
28010a5d 12547 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12548 struct ui_out *uiout = current_uiout;
28010a5d 12549
112e8700 12550 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
00eb2c4a 12551 : _("Catchpoint "));
112e8700
SM
12552 uiout->field_int ("bkptno", b->number);
12553 uiout->text (": ");
00eb2c4a 12554
f7f9143b
JB
12555 switch (ex)
12556 {
761269c8 12557 case ada_catch_exception:
28010a5d 12558 if (c->excep_string != NULL)
00eb2c4a
JB
12559 {
12560 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12561 struct cleanup *old_chain = make_cleanup (xfree, info);
12562
112e8700 12563 uiout->text (info);
00eb2c4a
JB
12564 do_cleanups (old_chain);
12565 }
f7f9143b 12566 else
112e8700 12567 uiout->text (_("all Ada exceptions"));
f7f9143b
JB
12568 break;
12569
761269c8 12570 case ada_catch_exception_unhandled:
112e8700 12571 uiout->text (_("unhandled Ada exceptions"));
f7f9143b
JB
12572 break;
12573
761269c8 12574 case ada_catch_assert:
112e8700 12575 uiout->text (_("failed Ada assertions"));
f7f9143b
JB
12576 break;
12577
12578 default:
12579 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12580 break;
12581 }
12582}
12583
6149aea9
PA
12584/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12585 for all exception catchpoint kinds. */
12586
12587static void
761269c8 12588print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12589 struct breakpoint *b, struct ui_file *fp)
12590{
28010a5d
PA
12591 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12592
6149aea9
PA
12593 switch (ex)
12594 {
761269c8 12595 case ada_catch_exception:
6149aea9 12596 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12597 if (c->excep_string != NULL)
12598 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12599 break;
12600
761269c8 12601 case ada_catch_exception_unhandled:
78076abc 12602 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12603 break;
12604
761269c8 12605 case ada_catch_assert:
6149aea9
PA
12606 fprintf_filtered (fp, "catch assert");
12607 break;
12608
12609 default:
12610 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12611 }
d9b3f62e 12612 print_recreate_thread (b, fp);
6149aea9
PA
12613}
12614
f7f9143b
JB
12615/* Virtual table for "catch exception" breakpoints. */
12616
28010a5d
PA
12617static struct bp_location *
12618allocate_location_catch_exception (struct breakpoint *self)
12619{
761269c8 12620 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12621}
12622
12623static void
12624re_set_catch_exception (struct breakpoint *b)
12625{
761269c8 12626 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12627}
12628
12629static void
12630check_status_catch_exception (bpstat bs)
12631{
761269c8 12632 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12633}
12634
f7f9143b 12635static enum print_stop_action
348d480f 12636print_it_catch_exception (bpstat bs)
f7f9143b 12637{
761269c8 12638 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12639}
12640
12641static void
a6d9a66e 12642print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12643{
761269c8 12644 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12645}
12646
12647static void
12648print_mention_catch_exception (struct breakpoint *b)
12649{
761269c8 12650 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12651}
12652
6149aea9
PA
12653static void
12654print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12655{
761269c8 12656 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12657}
12658
2060206e 12659static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12660
12661/* Virtual table for "catch exception unhandled" breakpoints. */
12662
28010a5d
PA
12663static struct bp_location *
12664allocate_location_catch_exception_unhandled (struct breakpoint *self)
12665{
761269c8 12666 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12667}
12668
12669static void
12670re_set_catch_exception_unhandled (struct breakpoint *b)
12671{
761269c8 12672 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12673}
12674
12675static void
12676check_status_catch_exception_unhandled (bpstat bs)
12677{
761269c8 12678 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12679}
12680
f7f9143b 12681static enum print_stop_action
348d480f 12682print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12683{
761269c8 12684 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12685}
12686
12687static void
a6d9a66e
UW
12688print_one_catch_exception_unhandled (struct breakpoint *b,
12689 struct bp_location **last_loc)
f7f9143b 12690{
761269c8 12691 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12692}
12693
12694static void
12695print_mention_catch_exception_unhandled (struct breakpoint *b)
12696{
761269c8 12697 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12698}
12699
6149aea9
PA
12700static void
12701print_recreate_catch_exception_unhandled (struct breakpoint *b,
12702 struct ui_file *fp)
12703{
761269c8 12704 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12705}
12706
2060206e 12707static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12708
12709/* Virtual table for "catch assert" breakpoints. */
12710
28010a5d
PA
12711static struct bp_location *
12712allocate_location_catch_assert (struct breakpoint *self)
12713{
761269c8 12714 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12715}
12716
12717static void
12718re_set_catch_assert (struct breakpoint *b)
12719{
761269c8 12720 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12721}
12722
12723static void
12724check_status_catch_assert (bpstat bs)
12725{
761269c8 12726 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12727}
12728
f7f9143b 12729static enum print_stop_action
348d480f 12730print_it_catch_assert (bpstat bs)
f7f9143b 12731{
761269c8 12732 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12733}
12734
12735static void
a6d9a66e 12736print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12737{
761269c8 12738 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12739}
12740
12741static void
12742print_mention_catch_assert (struct breakpoint *b)
12743{
761269c8 12744 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12745}
12746
6149aea9
PA
12747static void
12748print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12749{
761269c8 12750 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12751}
12752
2060206e 12753static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12754
f7f9143b
JB
12755/* Return a newly allocated copy of the first space-separated token
12756 in ARGSP, and then adjust ARGSP to point immediately after that
12757 token.
12758
12759 Return NULL if ARGPS does not contain any more tokens. */
12760
12761static char *
a121b7c1 12762ada_get_next_arg (const char **argsp)
f7f9143b 12763{
a121b7c1
PA
12764 const char *args = *argsp;
12765 const char *end;
f7f9143b
JB
12766 char *result;
12767
a121b7c1 12768 args = skip_spaces_const (args);
f7f9143b
JB
12769 if (args[0] == '\0')
12770 return NULL; /* No more arguments. */
12771
12772 /* Find the end of the current argument. */
12773
a121b7c1 12774 end = skip_to_space_const (args);
f7f9143b
JB
12775
12776 /* Adjust ARGSP to point to the start of the next argument. */
12777
12778 *argsp = end;
12779
12780 /* Make a copy of the current argument and return it. */
12781
224c3ddb 12782 result = (char *) xmalloc (end - args + 1);
f7f9143b
JB
12783 strncpy (result, args, end - args);
12784 result[end - args] = '\0';
12785
12786 return result;
12787}
12788
12789/* Split the arguments specified in a "catch exception" command.
12790 Set EX to the appropriate catchpoint type.
28010a5d 12791 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12792 specified by the user.
12793 If a condition is found at the end of the arguments, the condition
12794 expression is stored in COND_STRING (memory must be deallocated
12795 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12796
12797static void
a121b7c1 12798catch_ada_exception_command_split (const char *args,
761269c8 12799 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12800 char **excep_string,
12801 char **cond_string)
f7f9143b
JB
12802{
12803 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12804 char *exception_name;
5845583d 12805 char *cond = NULL;
f7f9143b
JB
12806
12807 exception_name = ada_get_next_arg (&args);
5845583d
JB
12808 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12809 {
12810 /* This is not an exception name; this is the start of a condition
12811 expression for a catchpoint on all exceptions. So, "un-get"
12812 this token, and set exception_name to NULL. */
12813 xfree (exception_name);
12814 exception_name = NULL;
12815 args -= 2;
12816 }
f7f9143b
JB
12817 make_cleanup (xfree, exception_name);
12818
5845583d 12819 /* Check to see if we have a condition. */
f7f9143b 12820
a121b7c1 12821 args = skip_spaces_const (args);
61012eef 12822 if (startswith (args, "if")
5845583d
JB
12823 && (isspace (args[2]) || args[2] == '\0'))
12824 {
12825 args += 2;
a121b7c1 12826 args = skip_spaces_const (args);
5845583d
JB
12827
12828 if (args[0] == '\0')
12829 error (_("Condition missing after `if' keyword"));
12830 cond = xstrdup (args);
12831 make_cleanup (xfree, cond);
12832
12833 args += strlen (args);
12834 }
12835
12836 /* Check that we do not have any more arguments. Anything else
12837 is unexpected. */
f7f9143b
JB
12838
12839 if (args[0] != '\0')
12840 error (_("Junk at end of expression"));
12841
12842 discard_cleanups (old_chain);
12843
12844 if (exception_name == NULL)
12845 {
12846 /* Catch all exceptions. */
761269c8 12847 *ex = ada_catch_exception;
28010a5d 12848 *excep_string = NULL;
f7f9143b
JB
12849 }
12850 else if (strcmp (exception_name, "unhandled") == 0)
12851 {
12852 /* Catch unhandled exceptions. */
761269c8 12853 *ex = ada_catch_exception_unhandled;
28010a5d 12854 *excep_string = NULL;
f7f9143b
JB
12855 }
12856 else
12857 {
12858 /* Catch a specific exception. */
761269c8 12859 *ex = ada_catch_exception;
28010a5d 12860 *excep_string = exception_name;
f7f9143b 12861 }
5845583d 12862 *cond_string = cond;
f7f9143b
JB
12863}
12864
12865/* Return the name of the symbol on which we should break in order to
12866 implement a catchpoint of the EX kind. */
12867
12868static const char *
761269c8 12869ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12870{
3eecfa55
JB
12871 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12872
12873 gdb_assert (data->exception_info != NULL);
0259addd 12874
f7f9143b
JB
12875 switch (ex)
12876 {
761269c8 12877 case ada_catch_exception:
3eecfa55 12878 return (data->exception_info->catch_exception_sym);
f7f9143b 12879 break;
761269c8 12880 case ada_catch_exception_unhandled:
3eecfa55 12881 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12882 break;
761269c8 12883 case ada_catch_assert:
3eecfa55 12884 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12885 break;
12886 default:
12887 internal_error (__FILE__, __LINE__,
12888 _("unexpected catchpoint kind (%d)"), ex);
12889 }
12890}
12891
12892/* Return the breakpoint ops "virtual table" used for catchpoints
12893 of the EX kind. */
12894
c0a91b2b 12895static const struct breakpoint_ops *
761269c8 12896ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12897{
12898 switch (ex)
12899 {
761269c8 12900 case ada_catch_exception:
f7f9143b
JB
12901 return (&catch_exception_breakpoint_ops);
12902 break;
761269c8 12903 case ada_catch_exception_unhandled:
f7f9143b
JB
12904 return (&catch_exception_unhandled_breakpoint_ops);
12905 break;
761269c8 12906 case ada_catch_assert:
f7f9143b
JB
12907 return (&catch_assert_breakpoint_ops);
12908 break;
12909 default:
12910 internal_error (__FILE__, __LINE__,
12911 _("unexpected catchpoint kind (%d)"), ex);
12912 }
12913}
12914
12915/* Return the condition that will be used to match the current exception
12916 being raised with the exception that the user wants to catch. This
12917 assumes that this condition is used when the inferior just triggered
12918 an exception catchpoint.
12919
12920 The string returned is a newly allocated string that needs to be
12921 deallocated later. */
12922
12923static char *
28010a5d 12924ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12925{
3d0b0fa3
JB
12926 int i;
12927
0963b4bd 12928 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12929 runtime units that have been compiled without debugging info; if
28010a5d 12930 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12931 exception (e.g. "constraint_error") then, during the evaluation
12932 of the condition expression, the symbol lookup on this name would
0963b4bd 12933 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12934 may then be set only on user-defined exceptions which have the
12935 same not-fully-qualified name (e.g. my_package.constraint_error).
12936
12937 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12938 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12939 exception constraint_error" is rewritten into "catch exception
12940 standard.constraint_error".
12941
12942 If an exception named contraint_error is defined in another package of
12943 the inferior program, then the only way to specify this exception as a
12944 breakpoint condition is to use its fully-qualified named:
12945 e.g. my_package.constraint_error. */
12946
12947 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12948 {
28010a5d 12949 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12950 {
12951 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12952 excep_string);
3d0b0fa3
JB
12953 }
12954 }
28010a5d 12955 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12956}
12957
12958/* Return the symtab_and_line that should be used to insert an exception
12959 catchpoint of the TYPE kind.
12960
28010a5d
PA
12961 EXCEP_STRING should contain the name of a specific exception that
12962 the catchpoint should catch, or NULL otherwise.
f7f9143b 12963
28010a5d
PA
12964 ADDR_STRING returns the name of the function where the real
12965 breakpoint that implements the catchpoints is set, depending on the
12966 type of catchpoint we need to create. */
f7f9143b
JB
12967
12968static struct symtab_and_line
761269c8 12969ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12970 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12971{
12972 const char *sym_name;
12973 struct symbol *sym;
f7f9143b 12974
0259addd
JB
12975 /* First, find out which exception support info to use. */
12976 ada_exception_support_info_sniffer ();
12977
12978 /* Then lookup the function on which we will break in order to catch
f7f9143b 12979 the Ada exceptions requested by the user. */
f7f9143b
JB
12980 sym_name = ada_exception_sym_name (ex);
12981 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12982
f17011e0
JB
12983 /* We can assume that SYM is not NULL at this stage. If the symbol
12984 did not exist, ada_exception_support_info_sniffer would have
12985 raised an exception.
f7f9143b 12986
f17011e0
JB
12987 Also, ada_exception_support_info_sniffer should have already
12988 verified that SYM is a function symbol. */
12989 gdb_assert (sym != NULL);
12990 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12991
12992 /* Set ADDR_STRING. */
f7f9143b
JB
12993 *addr_string = xstrdup (sym_name);
12994
f7f9143b 12995 /* Set OPS. */
4b9eee8c 12996 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12997
f17011e0 12998 return find_function_start_sal (sym, 1);
f7f9143b
JB
12999}
13000
b4a5b78b 13001/* Create an Ada exception catchpoint.
f7f9143b 13002
b4a5b78b 13003 EX_KIND is the kind of exception catchpoint to be created.
5845583d 13004
2df4d1d5
JB
13005 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
13006 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13007 of the exception to which this catchpoint applies. When not NULL,
13008 the string must be allocated on the heap, and its deallocation
13009 is no longer the responsibility of the caller.
13010
13011 COND_STRING, if not NULL, is the catchpoint condition. This string
13012 must be allocated on the heap, and its deallocation is no longer
13013 the responsibility of the caller.
f7f9143b 13014
b4a5b78b
JB
13015 TEMPFLAG, if nonzero, means that the underlying breakpoint
13016 should be temporary.
28010a5d 13017
b4a5b78b 13018 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 13019
349774ef 13020void
28010a5d 13021create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 13022 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 13023 char *excep_string,
5845583d 13024 char *cond_string,
28010a5d 13025 int tempflag,
349774ef 13026 int disabled,
28010a5d
PA
13027 int from_tty)
13028{
13029 struct ada_catchpoint *c;
b4a5b78b
JB
13030 char *addr_string = NULL;
13031 const struct breakpoint_ops *ops = NULL;
13032 struct symtab_and_line sal
13033 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d 13034
4d01a485 13035 c = new ada_catchpoint ();
c1fc2657 13036 init_ada_exception_breakpoint (c, gdbarch, sal, addr_string,
349774ef 13037 ops, tempflag, disabled, from_tty);
28010a5d
PA
13038 c->excep_string = excep_string;
13039 create_excep_cond_exprs (c);
5845583d 13040 if (cond_string != NULL)
c1fc2657
SM
13041 set_breakpoint_condition (c, cond_string, from_tty);
13042 install_breakpoint (0, c, 1);
f7f9143b
JB
13043}
13044
9ac4176b
PA
13045/* Implement the "catch exception" command. */
13046
13047static void
a121b7c1 13048catch_ada_exception_command (char *arg_entry, int from_tty,
9ac4176b
PA
13049 struct cmd_list_element *command)
13050{
a121b7c1 13051 const char *arg = arg_entry;
9ac4176b
PA
13052 struct gdbarch *gdbarch = get_current_arch ();
13053 int tempflag;
761269c8 13054 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 13055 char *excep_string = NULL;
5845583d 13056 char *cond_string = NULL;
9ac4176b
PA
13057
13058 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13059
13060 if (!arg)
13061 arg = "";
b4a5b78b
JB
13062 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
13063 &cond_string);
13064 create_ada_exception_catchpoint (gdbarch, ex_kind,
13065 excep_string, cond_string,
349774ef
JB
13066 tempflag, 1 /* enabled */,
13067 from_tty);
9ac4176b
PA
13068}
13069
b4a5b78b 13070/* Split the arguments specified in a "catch assert" command.
5845583d 13071
b4a5b78b
JB
13072 ARGS contains the command's arguments (or the empty string if
13073 no arguments were passed).
5845583d
JB
13074
13075 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 13076 (the memory needs to be deallocated after use). */
5845583d 13077
b4a5b78b 13078static void
a121b7c1 13079catch_ada_assert_command_split (const char *args, char **cond_string)
f7f9143b 13080{
a121b7c1 13081 args = skip_spaces_const (args);
f7f9143b 13082
5845583d 13083 /* Check whether a condition was provided. */
61012eef 13084 if (startswith (args, "if")
5845583d 13085 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 13086 {
5845583d 13087 args += 2;
a121b7c1 13088 args = skip_spaces_const (args);
5845583d
JB
13089 if (args[0] == '\0')
13090 error (_("condition missing after `if' keyword"));
13091 *cond_string = xstrdup (args);
f7f9143b
JB
13092 }
13093
5845583d
JB
13094 /* Otherwise, there should be no other argument at the end of
13095 the command. */
13096 else if (args[0] != '\0')
13097 error (_("Junk at end of arguments."));
f7f9143b
JB
13098}
13099
9ac4176b
PA
13100/* Implement the "catch assert" command. */
13101
13102static void
a121b7c1 13103catch_assert_command (char *arg_entry, int from_tty,
9ac4176b
PA
13104 struct cmd_list_element *command)
13105{
a121b7c1 13106 const char *arg = arg_entry;
9ac4176b
PA
13107 struct gdbarch *gdbarch = get_current_arch ();
13108 int tempflag;
5845583d 13109 char *cond_string = NULL;
9ac4176b
PA
13110
13111 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13112
13113 if (!arg)
13114 arg = "";
b4a5b78b 13115 catch_ada_assert_command_split (arg, &cond_string);
761269c8 13116 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 13117 NULL, cond_string,
349774ef
JB
13118 tempflag, 1 /* enabled */,
13119 from_tty);
9ac4176b 13120}
778865d3
JB
13121
13122/* Return non-zero if the symbol SYM is an Ada exception object. */
13123
13124static int
13125ada_is_exception_sym (struct symbol *sym)
13126{
13127 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13128
13129 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13130 && SYMBOL_CLASS (sym) != LOC_BLOCK
13131 && SYMBOL_CLASS (sym) != LOC_CONST
13132 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13133 && type_name != NULL && strcmp (type_name, "exception") == 0);
13134}
13135
13136/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13137 Ada exception object. This matches all exceptions except the ones
13138 defined by the Ada language. */
13139
13140static int
13141ada_is_non_standard_exception_sym (struct symbol *sym)
13142{
13143 int i;
13144
13145 if (!ada_is_exception_sym (sym))
13146 return 0;
13147
13148 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13149 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13150 return 0; /* A standard exception. */
13151
13152 /* Numeric_Error is also a standard exception, so exclude it.
13153 See the STANDARD_EXC description for more details as to why
13154 this exception is not listed in that array. */
13155 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13156 return 0;
13157
13158 return 1;
13159}
13160
13161/* A helper function for qsort, comparing two struct ada_exc_info
13162 objects.
13163
13164 The comparison is determined first by exception name, and then
13165 by exception address. */
13166
13167static int
13168compare_ada_exception_info (const void *a, const void *b)
13169{
13170 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
13171 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
13172 int result;
13173
13174 result = strcmp (exc_a->name, exc_b->name);
13175 if (result != 0)
13176 return result;
13177
13178 if (exc_a->addr < exc_b->addr)
13179 return -1;
13180 if (exc_a->addr > exc_b->addr)
13181 return 1;
13182
13183 return 0;
13184}
13185
13186/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13187 routine, but keeping the first SKIP elements untouched.
13188
13189 All duplicates are also removed. */
13190
13191static void
13192sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
13193 int skip)
13194{
13195 struct ada_exc_info *to_sort
13196 = VEC_address (ada_exc_info, *exceptions) + skip;
13197 int to_sort_len
13198 = VEC_length (ada_exc_info, *exceptions) - skip;
13199 int i, j;
13200
13201 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
13202 compare_ada_exception_info);
13203
13204 for (i = 1, j = 1; i < to_sort_len; i++)
13205 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
13206 to_sort[j++] = to_sort[i];
13207 to_sort_len = j;
13208 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
13209}
13210
778865d3
JB
13211/* Add all exceptions defined by the Ada standard whose name match
13212 a regular expression.
13213
13214 If PREG is not NULL, then this regexp_t object is used to
13215 perform the symbol name matching. Otherwise, no name-based
13216 filtering is performed.
13217
13218 EXCEPTIONS is a vector of exceptions to which matching exceptions
13219 gets pushed. */
13220
13221static void
2d7cc5c7
PA
13222ada_add_standard_exceptions (compiled_regex *preg,
13223 VEC(ada_exc_info) **exceptions)
778865d3
JB
13224{
13225 int i;
13226
13227 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13228 {
13229 if (preg == NULL
2d7cc5c7 13230 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
778865d3
JB
13231 {
13232 struct bound_minimal_symbol msymbol
13233 = ada_lookup_simple_minsym (standard_exc[i]);
13234
13235 if (msymbol.minsym != NULL)
13236 {
13237 struct ada_exc_info info
77e371c0 13238 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3
JB
13239
13240 VEC_safe_push (ada_exc_info, *exceptions, &info);
13241 }
13242 }
13243 }
13244}
13245
13246/* Add all Ada exceptions defined locally and accessible from the given
13247 FRAME.
13248
13249 If PREG is not NULL, then this regexp_t object is used to
13250 perform the symbol name matching. Otherwise, no name-based
13251 filtering is performed.
13252
13253 EXCEPTIONS is a vector of exceptions to which matching exceptions
13254 gets pushed. */
13255
13256static void
2d7cc5c7
PA
13257ada_add_exceptions_from_frame (compiled_regex *preg,
13258 struct frame_info *frame,
778865d3
JB
13259 VEC(ada_exc_info) **exceptions)
13260{
3977b71f 13261 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13262
13263 while (block != 0)
13264 {
13265 struct block_iterator iter;
13266 struct symbol *sym;
13267
13268 ALL_BLOCK_SYMBOLS (block, iter, sym)
13269 {
13270 switch (SYMBOL_CLASS (sym))
13271 {
13272 case LOC_TYPEDEF:
13273 case LOC_BLOCK:
13274 case LOC_CONST:
13275 break;
13276 default:
13277 if (ada_is_exception_sym (sym))
13278 {
13279 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13280 SYMBOL_VALUE_ADDRESS (sym)};
13281
13282 VEC_safe_push (ada_exc_info, *exceptions, &info);
13283 }
13284 }
13285 }
13286 if (BLOCK_FUNCTION (block) != NULL)
13287 break;
13288 block = BLOCK_SUPERBLOCK (block);
13289 }
13290}
13291
14bc53a8
PA
13292/* Return true if NAME matches PREG or if PREG is NULL. */
13293
13294static bool
2d7cc5c7 13295name_matches_regex (const char *name, compiled_regex *preg)
14bc53a8
PA
13296{
13297 return (preg == NULL
2d7cc5c7 13298 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
14bc53a8
PA
13299}
13300
778865d3
JB
13301/* Add all exceptions defined globally whose name name match
13302 a regular expression, excluding standard exceptions.
13303
13304 The reason we exclude standard exceptions is that they need
13305 to be handled separately: Standard exceptions are defined inside
13306 a runtime unit which is normally not compiled with debugging info,
13307 and thus usually do not show up in our symbol search. However,
13308 if the unit was in fact built with debugging info, we need to
13309 exclude them because they would duplicate the entry we found
13310 during the special loop that specifically searches for those
13311 standard exceptions.
13312
13313 If PREG is not NULL, then this regexp_t object is used to
13314 perform the symbol name matching. Otherwise, no name-based
13315 filtering is performed.
13316
13317 EXCEPTIONS is a vector of exceptions to which matching exceptions
13318 gets pushed. */
13319
13320static void
2d7cc5c7
PA
13321ada_add_global_exceptions (compiled_regex *preg,
13322 VEC(ada_exc_info) **exceptions)
778865d3
JB
13323{
13324 struct objfile *objfile;
43f3e411 13325 struct compunit_symtab *s;
778865d3 13326
14bc53a8
PA
13327 /* In Ada, the symbol "search name" is a linkage name, whereas the
13328 regular expression used to do the matching refers to the natural
13329 name. So match against the decoded name. */
13330 expand_symtabs_matching (NULL,
13331 [&] (const char *search_name)
13332 {
13333 const char *decoded = ada_decode (search_name);
13334 return name_matches_regex (decoded, preg);
13335 },
13336 NULL,
13337 VARIABLES_DOMAIN);
778865d3 13338
43f3e411 13339 ALL_COMPUNITS (objfile, s)
778865d3 13340 {
43f3e411 13341 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13342 int i;
13343
13344 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13345 {
13346 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13347 struct block_iterator iter;
13348 struct symbol *sym;
13349
13350 ALL_BLOCK_SYMBOLS (b, iter, sym)
13351 if (ada_is_non_standard_exception_sym (sym)
14bc53a8 13352 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
778865d3
JB
13353 {
13354 struct ada_exc_info info
13355 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13356
13357 VEC_safe_push (ada_exc_info, *exceptions, &info);
13358 }
13359 }
13360 }
13361}
13362
13363/* Implements ada_exceptions_list with the regular expression passed
13364 as a regex_t, rather than a string.
13365
13366 If not NULL, PREG is used to filter out exceptions whose names
13367 do not match. Otherwise, all exceptions are listed. */
13368
13369static VEC(ada_exc_info) *
2d7cc5c7 13370ada_exceptions_list_1 (compiled_regex *preg)
778865d3
JB
13371{
13372 VEC(ada_exc_info) *result = NULL;
13373 struct cleanup *old_chain
13374 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
13375 int prev_len;
13376
13377 /* First, list the known standard exceptions. These exceptions
13378 need to be handled separately, as they are usually defined in
13379 runtime units that have been compiled without debugging info. */
13380
13381 ada_add_standard_exceptions (preg, &result);
13382
13383 /* Next, find all exceptions whose scope is local and accessible
13384 from the currently selected frame. */
13385
13386 if (has_stack_frames ())
13387 {
13388 prev_len = VEC_length (ada_exc_info, result);
13389 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13390 &result);
13391 if (VEC_length (ada_exc_info, result) > prev_len)
13392 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13393 }
13394
13395 /* Add all exceptions whose scope is global. */
13396
13397 prev_len = VEC_length (ada_exc_info, result);
13398 ada_add_global_exceptions (preg, &result);
13399 if (VEC_length (ada_exc_info, result) > prev_len)
13400 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13401
13402 discard_cleanups (old_chain);
13403 return result;
13404}
13405
13406/* Return a vector of ada_exc_info.
13407
13408 If REGEXP is NULL, all exceptions are included in the result.
13409 Otherwise, it should contain a valid regular expression,
13410 and only the exceptions whose names match that regular expression
13411 are included in the result.
13412
13413 The exceptions are sorted in the following order:
13414 - Standard exceptions (defined by the Ada language), in
13415 alphabetical order;
13416 - Exceptions only visible from the current frame, in
13417 alphabetical order;
13418 - Exceptions whose scope is global, in alphabetical order. */
13419
13420VEC(ada_exc_info) *
13421ada_exceptions_list (const char *regexp)
13422{
2d7cc5c7
PA
13423 if (regexp == NULL)
13424 return ada_exceptions_list_1 (NULL);
778865d3 13425
2d7cc5c7
PA
13426 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13427 return ada_exceptions_list_1 (&reg);
778865d3
JB
13428}
13429
13430/* Implement the "info exceptions" command. */
13431
13432static void
13433info_exceptions_command (char *regexp, int from_tty)
13434{
13435 VEC(ada_exc_info) *exceptions;
13436 struct cleanup *cleanup;
13437 struct gdbarch *gdbarch = get_current_arch ();
13438 int ix;
13439 struct ada_exc_info *info;
13440
13441 exceptions = ada_exceptions_list (regexp);
13442 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
13443
13444 if (regexp != NULL)
13445 printf_filtered
13446 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13447 else
13448 printf_filtered (_("All defined Ada exceptions:\n"));
13449
13450 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
13451 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
13452
13453 do_cleanups (cleanup);
13454}
13455
4c4b4cd2
PH
13456 /* Operators */
13457/* Information about operators given special treatment in functions
13458 below. */
13459/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13460
13461#define ADA_OPERATORS \
13462 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13463 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13464 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13465 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13466 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13467 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13468 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13469 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13470 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13471 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13472 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13473 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13474 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13475 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13476 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13477 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13478 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13479 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13480 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13481
13482static void
554794dc
SDJ
13483ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13484 int *argsp)
4c4b4cd2
PH
13485{
13486 switch (exp->elts[pc - 1].opcode)
13487 {
76a01679 13488 default:
4c4b4cd2
PH
13489 operator_length_standard (exp, pc, oplenp, argsp);
13490 break;
13491
13492#define OP_DEFN(op, len, args, binop) \
13493 case op: *oplenp = len; *argsp = args; break;
13494 ADA_OPERATORS;
13495#undef OP_DEFN
52ce6436
PH
13496
13497 case OP_AGGREGATE:
13498 *oplenp = 3;
13499 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13500 break;
13501
13502 case OP_CHOICES:
13503 *oplenp = 3;
13504 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13505 break;
4c4b4cd2
PH
13506 }
13507}
13508
c0201579
JK
13509/* Implementation of the exp_descriptor method operator_check. */
13510
13511static int
13512ada_operator_check (struct expression *exp, int pos,
13513 int (*objfile_func) (struct objfile *objfile, void *data),
13514 void *data)
13515{
13516 const union exp_element *const elts = exp->elts;
13517 struct type *type = NULL;
13518
13519 switch (elts[pos].opcode)
13520 {
13521 case UNOP_IN_RANGE:
13522 case UNOP_QUAL:
13523 type = elts[pos + 1].type;
13524 break;
13525
13526 default:
13527 return operator_check_standard (exp, pos, objfile_func, data);
13528 }
13529
13530 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13531
13532 if (type && TYPE_OBJFILE (type)
13533 && (*objfile_func) (TYPE_OBJFILE (type), data))
13534 return 1;
13535
13536 return 0;
13537}
13538
a121b7c1 13539static const char *
4c4b4cd2
PH
13540ada_op_name (enum exp_opcode opcode)
13541{
13542 switch (opcode)
13543 {
76a01679 13544 default:
4c4b4cd2 13545 return op_name_standard (opcode);
52ce6436 13546
4c4b4cd2
PH
13547#define OP_DEFN(op, len, args, binop) case op: return #op;
13548 ADA_OPERATORS;
13549#undef OP_DEFN
52ce6436
PH
13550
13551 case OP_AGGREGATE:
13552 return "OP_AGGREGATE";
13553 case OP_CHOICES:
13554 return "OP_CHOICES";
13555 case OP_NAME:
13556 return "OP_NAME";
4c4b4cd2
PH
13557 }
13558}
13559
13560/* As for operator_length, but assumes PC is pointing at the first
13561 element of the operator, and gives meaningful results only for the
52ce6436 13562 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13563
13564static void
76a01679
JB
13565ada_forward_operator_length (struct expression *exp, int pc,
13566 int *oplenp, int *argsp)
4c4b4cd2 13567{
76a01679 13568 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13569 {
13570 default:
13571 *oplenp = *argsp = 0;
13572 break;
52ce6436 13573
4c4b4cd2
PH
13574#define OP_DEFN(op, len, args, binop) \
13575 case op: *oplenp = len; *argsp = args; break;
13576 ADA_OPERATORS;
13577#undef OP_DEFN
52ce6436
PH
13578
13579 case OP_AGGREGATE:
13580 *oplenp = 3;
13581 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13582 break;
13583
13584 case OP_CHOICES:
13585 *oplenp = 3;
13586 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13587 break;
13588
13589 case OP_STRING:
13590 case OP_NAME:
13591 {
13592 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13593
52ce6436
PH
13594 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13595 *argsp = 0;
13596 break;
13597 }
4c4b4cd2
PH
13598 }
13599}
13600
13601static int
13602ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13603{
13604 enum exp_opcode op = exp->elts[elt].opcode;
13605 int oplen, nargs;
13606 int pc = elt;
13607 int i;
76a01679 13608
4c4b4cd2
PH
13609 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13610
76a01679 13611 switch (op)
4c4b4cd2 13612 {
76a01679 13613 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13614 case OP_ATR_FIRST:
13615 case OP_ATR_LAST:
13616 case OP_ATR_LENGTH:
13617 case OP_ATR_IMAGE:
13618 case OP_ATR_MAX:
13619 case OP_ATR_MIN:
13620 case OP_ATR_MODULUS:
13621 case OP_ATR_POS:
13622 case OP_ATR_SIZE:
13623 case OP_ATR_TAG:
13624 case OP_ATR_VAL:
13625 break;
13626
13627 case UNOP_IN_RANGE:
13628 case UNOP_QUAL:
323e0a4a
AC
13629 /* XXX: gdb_sprint_host_address, type_sprint */
13630 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13631 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13632 fprintf_filtered (stream, " (");
13633 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13634 fprintf_filtered (stream, ")");
13635 break;
13636 case BINOP_IN_BOUNDS:
52ce6436
PH
13637 fprintf_filtered (stream, " (%d)",
13638 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13639 break;
13640 case TERNOP_IN_RANGE:
13641 break;
13642
52ce6436
PH
13643 case OP_AGGREGATE:
13644 case OP_OTHERS:
13645 case OP_DISCRETE_RANGE:
13646 case OP_POSITIONAL:
13647 case OP_CHOICES:
13648 break;
13649
13650 case OP_NAME:
13651 case OP_STRING:
13652 {
13653 char *name = &exp->elts[elt + 2].string;
13654 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13655
52ce6436
PH
13656 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13657 break;
13658 }
13659
4c4b4cd2
PH
13660 default:
13661 return dump_subexp_body_standard (exp, stream, elt);
13662 }
13663
13664 elt += oplen;
13665 for (i = 0; i < nargs; i += 1)
13666 elt = dump_subexp (exp, stream, elt);
13667
13668 return elt;
13669}
13670
13671/* The Ada extension of print_subexp (q.v.). */
13672
76a01679
JB
13673static void
13674ada_print_subexp (struct expression *exp, int *pos,
13675 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13676{
52ce6436 13677 int oplen, nargs, i;
4c4b4cd2
PH
13678 int pc = *pos;
13679 enum exp_opcode op = exp->elts[pc].opcode;
13680
13681 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13682
52ce6436 13683 *pos += oplen;
4c4b4cd2
PH
13684 switch (op)
13685 {
13686 default:
52ce6436 13687 *pos -= oplen;
4c4b4cd2
PH
13688 print_subexp_standard (exp, pos, stream, prec);
13689 return;
13690
13691 case OP_VAR_VALUE:
4c4b4cd2
PH
13692 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13693 return;
13694
13695 case BINOP_IN_BOUNDS:
323e0a4a 13696 /* XXX: sprint_subexp */
4c4b4cd2 13697 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13698 fputs_filtered (" in ", stream);
4c4b4cd2 13699 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13700 fputs_filtered ("'range", stream);
4c4b4cd2 13701 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13702 fprintf_filtered (stream, "(%ld)",
13703 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13704 return;
13705
13706 case TERNOP_IN_RANGE:
4c4b4cd2 13707 if (prec >= PREC_EQUAL)
76a01679 13708 fputs_filtered ("(", stream);
323e0a4a 13709 /* XXX: sprint_subexp */
4c4b4cd2 13710 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13711 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13712 print_subexp (exp, pos, stream, PREC_EQUAL);
13713 fputs_filtered (" .. ", stream);
13714 print_subexp (exp, pos, stream, PREC_EQUAL);
13715 if (prec >= PREC_EQUAL)
76a01679
JB
13716 fputs_filtered (")", stream);
13717 return;
4c4b4cd2
PH
13718
13719 case OP_ATR_FIRST:
13720 case OP_ATR_LAST:
13721 case OP_ATR_LENGTH:
13722 case OP_ATR_IMAGE:
13723 case OP_ATR_MAX:
13724 case OP_ATR_MIN:
13725 case OP_ATR_MODULUS:
13726 case OP_ATR_POS:
13727 case OP_ATR_SIZE:
13728 case OP_ATR_TAG:
13729 case OP_ATR_VAL:
4c4b4cd2 13730 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13731 {
13732 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13733 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13734 &type_print_raw_options);
76a01679
JB
13735 *pos += 3;
13736 }
4c4b4cd2 13737 else
76a01679 13738 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13739 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13740 if (nargs > 1)
76a01679
JB
13741 {
13742 int tem;
5b4ee69b 13743
76a01679
JB
13744 for (tem = 1; tem < nargs; tem += 1)
13745 {
13746 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13747 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13748 }
13749 fputs_filtered (")", stream);
13750 }
4c4b4cd2 13751 return;
14f9c5c9 13752
4c4b4cd2 13753 case UNOP_QUAL:
4c4b4cd2
PH
13754 type_print (exp->elts[pc + 1].type, "", stream, 0);
13755 fputs_filtered ("'(", stream);
13756 print_subexp (exp, pos, stream, PREC_PREFIX);
13757 fputs_filtered (")", stream);
13758 return;
14f9c5c9 13759
4c4b4cd2 13760 case UNOP_IN_RANGE:
323e0a4a 13761 /* XXX: sprint_subexp */
4c4b4cd2 13762 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13763 fputs_filtered (" in ", stream);
79d43c61
TT
13764 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13765 &type_print_raw_options);
4c4b4cd2 13766 return;
52ce6436
PH
13767
13768 case OP_DISCRETE_RANGE:
13769 print_subexp (exp, pos, stream, PREC_SUFFIX);
13770 fputs_filtered ("..", stream);
13771 print_subexp (exp, pos, stream, PREC_SUFFIX);
13772 return;
13773
13774 case OP_OTHERS:
13775 fputs_filtered ("others => ", stream);
13776 print_subexp (exp, pos, stream, PREC_SUFFIX);
13777 return;
13778
13779 case OP_CHOICES:
13780 for (i = 0; i < nargs-1; i += 1)
13781 {
13782 if (i > 0)
13783 fputs_filtered ("|", stream);
13784 print_subexp (exp, pos, stream, PREC_SUFFIX);
13785 }
13786 fputs_filtered (" => ", stream);
13787 print_subexp (exp, pos, stream, PREC_SUFFIX);
13788 return;
13789
13790 case OP_POSITIONAL:
13791 print_subexp (exp, pos, stream, PREC_SUFFIX);
13792 return;
13793
13794 case OP_AGGREGATE:
13795 fputs_filtered ("(", stream);
13796 for (i = 0; i < nargs; i += 1)
13797 {
13798 if (i > 0)
13799 fputs_filtered (", ", stream);
13800 print_subexp (exp, pos, stream, PREC_SUFFIX);
13801 }
13802 fputs_filtered (")", stream);
13803 return;
4c4b4cd2
PH
13804 }
13805}
14f9c5c9
AS
13806
13807/* Table mapping opcodes into strings for printing operators
13808 and precedences of the operators. */
13809
d2e4a39e
AS
13810static const struct op_print ada_op_print_tab[] = {
13811 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13812 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13813 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13814 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13815 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13816 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13817 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13818 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13819 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13820 {">=", BINOP_GEQ, PREC_ORDER, 0},
13821 {">", BINOP_GTR, PREC_ORDER, 0},
13822 {"<", BINOP_LESS, PREC_ORDER, 0},
13823 {">>", BINOP_RSH, PREC_SHIFT, 0},
13824 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13825 {"+", BINOP_ADD, PREC_ADD, 0},
13826 {"-", BINOP_SUB, PREC_ADD, 0},
13827 {"&", BINOP_CONCAT, PREC_ADD, 0},
13828 {"*", BINOP_MUL, PREC_MUL, 0},
13829 {"/", BINOP_DIV, PREC_MUL, 0},
13830 {"rem", BINOP_REM, PREC_MUL, 0},
13831 {"mod", BINOP_MOD, PREC_MUL, 0},
13832 {"**", BINOP_EXP, PREC_REPEAT, 0},
13833 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13834 {"-", UNOP_NEG, PREC_PREFIX, 0},
13835 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13836 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13837 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13838 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13839 {".all", UNOP_IND, PREC_SUFFIX, 1},
13840 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13841 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 13842 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
13843};
13844\f
72d5681a
PH
13845enum ada_primitive_types {
13846 ada_primitive_type_int,
13847 ada_primitive_type_long,
13848 ada_primitive_type_short,
13849 ada_primitive_type_char,
13850 ada_primitive_type_float,
13851 ada_primitive_type_double,
13852 ada_primitive_type_void,
13853 ada_primitive_type_long_long,
13854 ada_primitive_type_long_double,
13855 ada_primitive_type_natural,
13856 ada_primitive_type_positive,
13857 ada_primitive_type_system_address,
13858 nr_ada_primitive_types
13859};
6c038f32
PH
13860
13861static void
d4a9a881 13862ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13863 struct language_arch_info *lai)
13864{
d4a9a881 13865 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13866
72d5681a 13867 lai->primitive_type_vector
d4a9a881 13868 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13869 struct type *);
e9bb382b
UW
13870
13871 lai->primitive_type_vector [ada_primitive_type_int]
13872 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13873 0, "integer");
13874 lai->primitive_type_vector [ada_primitive_type_long]
13875 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13876 0, "long_integer");
13877 lai->primitive_type_vector [ada_primitive_type_short]
13878 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13879 0, "short_integer");
13880 lai->string_char_type
13881 = lai->primitive_type_vector [ada_primitive_type_char]
cd7c1778 13882 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
e9bb382b
UW
13883 lai->primitive_type_vector [ada_primitive_type_float]
13884 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 13885 "float", gdbarch_float_format (gdbarch));
e9bb382b
UW
13886 lai->primitive_type_vector [ada_primitive_type_double]
13887 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 13888 "long_float", gdbarch_double_format (gdbarch));
e9bb382b
UW
13889 lai->primitive_type_vector [ada_primitive_type_long_long]
13890 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13891 0, "long_long_integer");
13892 lai->primitive_type_vector [ada_primitive_type_long_double]
5f3bceb6 13893 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
49f190bc 13894 "long_long_float", gdbarch_long_double_format (gdbarch));
e9bb382b
UW
13895 lai->primitive_type_vector [ada_primitive_type_natural]
13896 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13897 0, "natural");
13898 lai->primitive_type_vector [ada_primitive_type_positive]
13899 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13900 0, "positive");
13901 lai->primitive_type_vector [ada_primitive_type_void]
13902 = builtin->builtin_void;
13903
13904 lai->primitive_type_vector [ada_primitive_type_system_address]
13905 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13906 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13907 = "system__address";
fbb06eb1 13908
47e729a8 13909 lai->bool_type_symbol = NULL;
fbb06eb1 13910 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13911}
6c038f32
PH
13912\f
13913 /* Language vector */
13914
13915/* Not really used, but needed in the ada_language_defn. */
13916
13917static void
6c7a06a3 13918emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13919{
6c7a06a3 13920 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13921}
13922
13923static int
410a0ff2 13924parse (struct parser_state *ps)
6c038f32
PH
13925{
13926 warnings_issued = 0;
410a0ff2 13927 return ada_parse (ps);
6c038f32
PH
13928}
13929
13930static const struct exp_descriptor ada_exp_descriptor = {
13931 ada_print_subexp,
13932 ada_operator_length,
c0201579 13933 ada_operator_check,
6c038f32
PH
13934 ada_op_name,
13935 ada_dump_subexp_body,
13936 ada_evaluate_subexp
13937};
13938
1a119f36 13939/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13940 for Ada. */
13941
1a119f36
JB
13942static symbol_name_cmp_ftype
13943ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13944{
13945 if (should_use_wild_match (lookup_name))
13946 return wild_match;
13947 else
13948 return compare_names;
13949}
13950
a5ee536b
JB
13951/* Implement the "la_read_var_value" language_defn method for Ada. */
13952
13953static struct value *
63e43d3a
PMR
13954ada_read_var_value (struct symbol *var, const struct block *var_block,
13955 struct frame_info *frame)
a5ee536b 13956{
3977b71f 13957 const struct block *frame_block = NULL;
a5ee536b
JB
13958 struct symbol *renaming_sym = NULL;
13959
13960 /* The only case where default_read_var_value is not sufficient
13961 is when VAR is a renaming... */
13962 if (frame)
13963 frame_block = get_frame_block (frame, NULL);
13964 if (frame_block)
13965 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13966 if (renaming_sym != NULL)
13967 return ada_read_renaming_var_value (renaming_sym, frame_block);
13968
13969 /* This is a typical case where we expect the default_read_var_value
13970 function to work. */
63e43d3a 13971 return default_read_var_value (var, var_block, frame);
a5ee536b
JB
13972}
13973
56618e20
TT
13974static const char *ada_extensions[] =
13975{
13976 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13977};
13978
6c038f32
PH
13979const struct language_defn ada_language_defn = {
13980 "ada", /* Language name */
6abde28f 13981 "Ada",
6c038f32 13982 language_ada,
6c038f32 13983 range_check_off,
6c038f32
PH
13984 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13985 that's not quite what this means. */
6c038f32 13986 array_row_major,
9a044a89 13987 macro_expansion_no,
56618e20 13988 ada_extensions,
6c038f32
PH
13989 &ada_exp_descriptor,
13990 parse,
b3f11165 13991 ada_yyerror,
6c038f32
PH
13992 resolve,
13993 ada_printchar, /* Print a character constant */
13994 ada_printstr, /* Function to print string constant */
13995 emit_char, /* Function to print single char (not used) */
6c038f32 13996 ada_print_type, /* Print a type using appropriate syntax */
be942545 13997 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13998 ada_val_print, /* Print a value using appropriate syntax */
13999 ada_value_print, /* Print a top-level value */
a5ee536b 14000 ada_read_var_value, /* la_read_var_value */
6c038f32 14001 NULL, /* Language specific skip_trampoline */
2b2d9e11 14002 NULL, /* name_of_this */
6c038f32
PH
14003 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14004 basic_lookup_transparent_type, /* lookup_transparent_type */
14005 ada_la_decode, /* Language specific symbol demangler */
8b302db8 14006 ada_sniff_from_mangled_name,
0963b4bd
MS
14007 NULL, /* Language specific
14008 class_name_from_physname */
6c038f32
PH
14009 ada_op_print_tab, /* expression operators for printing */
14010 0, /* c-style arrays */
14011 1, /* String lower bound */
6c038f32 14012 ada_get_gdb_completer_word_break_characters,
41d27058 14013 ada_make_symbol_completion_list,
72d5681a 14014 ada_language_arch_info,
e79af960 14015 ada_print_array_index,
41f1b697 14016 default_pass_by_reference,
ae6a3a4c 14017 c_get_string,
43cc5389 14018 c_watch_location_expression,
1a119f36 14019 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 14020 ada_iterate_over_symbols,
a53b64ea 14021 &ada_varobj_ops,
bb2ec1b3
TT
14022 NULL,
14023 NULL,
6c038f32
PH
14024 LANG_MAGIC
14025};
14026
2c0b251b
PA
14027/* Provide a prototype to silence -Wmissing-prototypes. */
14028extern initialize_file_ftype _initialize_ada_language;
14029
5bf03f13
JB
14030/* Command-list for the "set/show ada" prefix command. */
14031static struct cmd_list_element *set_ada_list;
14032static struct cmd_list_element *show_ada_list;
14033
14034/* Implement the "set ada" prefix command. */
14035
14036static void
14037set_ada_command (char *arg, int from_tty)
14038{
14039 printf_unfiltered (_(\
14040"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 14041 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
14042}
14043
14044/* Implement the "show ada" prefix command. */
14045
14046static void
14047show_ada_command (char *args, int from_tty)
14048{
14049 cmd_show_list (show_ada_list, from_tty, "");
14050}
14051
2060206e
PA
14052static void
14053initialize_ada_catchpoint_ops (void)
14054{
14055 struct breakpoint_ops *ops;
14056
14057 initialize_breakpoint_ops ();
14058
14059 ops = &catch_exception_breakpoint_ops;
14060 *ops = bkpt_breakpoint_ops;
2060206e
PA
14061 ops->allocate_location = allocate_location_catch_exception;
14062 ops->re_set = re_set_catch_exception;
14063 ops->check_status = check_status_catch_exception;
14064 ops->print_it = print_it_catch_exception;
14065 ops->print_one = print_one_catch_exception;
14066 ops->print_mention = print_mention_catch_exception;
14067 ops->print_recreate = print_recreate_catch_exception;
14068
14069 ops = &catch_exception_unhandled_breakpoint_ops;
14070 *ops = bkpt_breakpoint_ops;
2060206e
PA
14071 ops->allocate_location = allocate_location_catch_exception_unhandled;
14072 ops->re_set = re_set_catch_exception_unhandled;
14073 ops->check_status = check_status_catch_exception_unhandled;
14074 ops->print_it = print_it_catch_exception_unhandled;
14075 ops->print_one = print_one_catch_exception_unhandled;
14076 ops->print_mention = print_mention_catch_exception_unhandled;
14077 ops->print_recreate = print_recreate_catch_exception_unhandled;
14078
14079 ops = &catch_assert_breakpoint_ops;
14080 *ops = bkpt_breakpoint_ops;
2060206e
PA
14081 ops->allocate_location = allocate_location_catch_assert;
14082 ops->re_set = re_set_catch_assert;
14083 ops->check_status = check_status_catch_assert;
14084 ops->print_it = print_it_catch_assert;
14085 ops->print_one = print_one_catch_assert;
14086 ops->print_mention = print_mention_catch_assert;
14087 ops->print_recreate = print_recreate_catch_assert;
14088}
14089
3d9434b5
JB
14090/* This module's 'new_objfile' observer. */
14091
14092static void
14093ada_new_objfile_observer (struct objfile *objfile)
14094{
14095 ada_clear_symbol_cache ();
14096}
14097
14098/* This module's 'free_objfile' observer. */
14099
14100static void
14101ada_free_objfile_observer (struct objfile *objfile)
14102{
14103 ada_clear_symbol_cache ();
14104}
14105
d2e4a39e 14106void
6c038f32 14107_initialize_ada_language (void)
14f9c5c9 14108{
6c038f32
PH
14109 add_language (&ada_language_defn);
14110
2060206e
PA
14111 initialize_ada_catchpoint_ops ();
14112
5bf03f13
JB
14113 add_prefix_cmd ("ada", no_class, set_ada_command,
14114 _("Prefix command for changing Ada-specfic settings"),
14115 &set_ada_list, "set ada ", 0, &setlist);
14116
14117 add_prefix_cmd ("ada", no_class, show_ada_command,
14118 _("Generic command for showing Ada-specific settings."),
14119 &show_ada_list, "show ada ", 0, &showlist);
14120
14121 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14122 &trust_pad_over_xvs, _("\
14123Enable or disable an optimization trusting PAD types over XVS types"), _("\
14124Show whether an optimization trusting PAD types over XVS types is activated"),
14125 _("\
14126This is related to the encoding used by the GNAT compiler. The debugger\n\
14127should normally trust the contents of PAD types, but certain older versions\n\
14128of GNAT have a bug that sometimes causes the information in the PAD type\n\
14129to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14130work around this bug. It is always safe to turn this option \"off\", but\n\
14131this incurs a slight performance penalty, so it is recommended to NOT change\n\
14132this option to \"off\" unless necessary."),
14133 NULL, NULL, &set_ada_list, &show_ada_list);
14134
d72413e6
PMR
14135 add_setshow_boolean_cmd ("print-signatures", class_vars,
14136 &print_signatures, _("\
14137Enable or disable the output of formal and return types for functions in the \
14138overloads selection menu"), _("\
14139Show whether the output of formal and return types for functions in the \
14140overloads selection menu is activated"),
14141 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14142
9ac4176b
PA
14143 add_catch_command ("exception", _("\
14144Catch Ada exceptions, when raised.\n\
14145With an argument, catch only exceptions with the given name."),
14146 catch_ada_exception_command,
14147 NULL,
14148 CATCH_PERMANENT,
14149 CATCH_TEMPORARY);
14150 add_catch_command ("assert", _("\
14151Catch failed Ada assertions, when raised.\n\
14152With an argument, catch only exceptions with the given name."),
14153 catch_assert_command,
14154 NULL,
14155 CATCH_PERMANENT,
14156 CATCH_TEMPORARY);
14157
6c038f32 14158 varsize_limit = 65536;
6c038f32 14159
778865d3
JB
14160 add_info ("exceptions", info_exceptions_command,
14161 _("\
14162List all Ada exception names.\n\
14163If a regular expression is passed as an argument, only those matching\n\
14164the regular expression are listed."));
14165
c6044dd1
JB
14166 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14167 _("Set Ada maintenance-related variables."),
14168 &maint_set_ada_cmdlist, "maintenance set ada ",
14169 0/*allow-unknown*/, &maintenance_set_cmdlist);
14170
14171 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14172 _("Show Ada maintenance-related variables"),
14173 &maint_show_ada_cmdlist, "maintenance show ada ",
14174 0/*allow-unknown*/, &maintenance_show_cmdlist);
14175
14176 add_setshow_boolean_cmd
14177 ("ignore-descriptive-types", class_maintenance,
14178 &ada_ignore_descriptive_types_p,
14179 _("Set whether descriptive types generated by GNAT should be ignored."),
14180 _("Show whether descriptive types generated by GNAT should be ignored."),
14181 _("\
14182When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14183DWARF attribute."),
14184 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14185
6c038f32
PH
14186 obstack_init (&symbol_list_obstack);
14187
14188 decoded_names_store = htab_create_alloc
14189 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
14190 NULL, xcalloc, xfree);
6b69afc4 14191
3d9434b5
JB
14192 /* The ada-lang observers. */
14193 observer_attach_new_objfile (ada_new_objfile_observer);
14194 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 14195 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
14196
14197 /* Setup various context-specific data. */
e802dbe0 14198 ada_inferior_data
8e260fc0 14199 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
14200 ada_pspace_data_handle
14201 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 14202}