]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
gas 0f handling
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
6e681866 1/* Ada language support routines for GDB, the GNU debugger.
10a2c479 2
32d0add0 3 Copyright (C) 1992-2015 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"
14f9c5c9 56
ccefe4c4 57#include "psymtab.h"
40bc484c 58#include "value.h"
956a9fb9 59#include "mi/mi-common.h"
9ac4176b 60#include "arch-utils.h"
0fcd72ba 61#include "cli/cli-utils.h"
ccefe4c4 62
4c4b4cd2 63/* Define whether or not the C operator '/' truncates towards zero for
0963b4bd 64 differently signed operands (truncation direction is undefined in C).
4c4b4cd2
PH
65 Copied from valarith.c. */
66
67#ifndef TRUNCATION_TOWARDS_ZERO
68#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69#endif
70
d2e4a39e 71static struct type *desc_base_type (struct type *);
14f9c5c9 72
d2e4a39e 73static struct type *desc_bounds_type (struct type *);
14f9c5c9 74
d2e4a39e 75static struct value *desc_bounds (struct value *);
14f9c5c9 76
d2e4a39e 77static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 78
d2e4a39e 79static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 80
556bdfd4 81static struct type *desc_data_target_type (struct type *);
14f9c5c9 82
d2e4a39e 83static struct value *desc_data (struct value *);
14f9c5c9 84
d2e4a39e 85static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 86
d2e4a39e 87static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 88
d2e4a39e 89static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 90
d2e4a39e 91static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 92
d2e4a39e 93static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 94
d2e4a39e 95static struct type *desc_index_type (struct type *, int);
14f9c5c9 96
d2e4a39e 97static int desc_arity (struct type *);
14f9c5c9 98
d2e4a39e 99static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 100
d2e4a39e 101static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 102
40658b94
PH
103static int full_match (const char *, const char *);
104
40bc484c 105static struct value *make_array_descriptor (struct type *, struct value *);
14f9c5c9 106
4c4b4cd2 107static void ada_add_block_symbols (struct obstack *,
f0c5f9b2 108 const struct block *, const char *,
2570f2b7 109 domain_enum, struct objfile *, int);
14f9c5c9 110
d12307c1 111static int is_nonfunction (struct block_symbol *, int);
14f9c5c9 112
76a01679 113static void add_defn_to_vec (struct obstack *, struct symbol *,
f0c5f9b2 114 const struct block *);
14f9c5c9 115
4c4b4cd2
PH
116static int num_defns_collected (struct obstack *);
117
d12307c1 118static struct block_symbol *defns_collected (struct obstack *, int);
14f9c5c9 119
4c4b4cd2 120static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 121 struct type *);
14f9c5c9 122
d2e4a39e 123static void replace_operator_with_call (struct expression **, int, int, int,
270140bd 124 struct symbol *, const struct block *);
14f9c5c9 125
d2e4a39e 126static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 127
4c4b4cd2
PH
128static char *ada_op_name (enum exp_opcode);
129
130static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 131
d2e4a39e 132static int numeric_type_p (struct type *);
14f9c5c9 133
d2e4a39e 134static int integer_type_p (struct type *);
14f9c5c9 135
d2e4a39e 136static int scalar_type_p (struct type *);
14f9c5c9 137
d2e4a39e 138static int discrete_type_p (struct type *);
14f9c5c9 139
aeb5907d
JB
140static enum ada_renaming_category parse_old_style_renaming (struct type *,
141 const char **,
142 int *,
143 const char **);
144
145static struct symbol *find_old_style_renaming_symbol (const char *,
270140bd 146 const struct block *);
aeb5907d 147
4c4b4cd2 148static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 149 int, int, int *);
4c4b4cd2 150
d2e4a39e 151static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 152
b4ba55a1
JB
153static struct type *ada_find_parallel_type_with_name (struct type *,
154 const char *);
155
d2e4a39e 156static int is_dynamic_field (struct type *, int);
14f9c5c9 157
10a2c479 158static struct type *to_fixed_variant_branch_type (struct type *,
fc1a4b47 159 const gdb_byte *,
4c4b4cd2
PH
160 CORE_ADDR, struct value *);
161
162static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 163
28c85d6c 164static struct type *to_fixed_range_type (struct type *, struct value *);
14f9c5c9 165
d2e4a39e 166static struct type *to_static_fixed_type (struct type *);
f192137b 167static struct type *static_unwrap_type (struct type *type);
14f9c5c9 168
d2e4a39e 169static struct value *unwrap_value (struct value *);
14f9c5c9 170
ad82864c 171static struct type *constrained_packed_array_type (struct type *, long *);
14f9c5c9 172
ad82864c 173static struct type *decode_constrained_packed_array_type (struct type *);
14f9c5c9 174
ad82864c
JB
175static long decode_packed_array_bitsize (struct type *);
176
177static struct value *decode_constrained_packed_array (struct value *);
178
179static int ada_is_packed_array_type (struct type *);
180
181static int ada_is_unconstrained_packed_array_type (struct type *);
14f9c5c9 182
d2e4a39e 183static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 184 struct value **);
14f9c5c9 185
50810684 186static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
52ce6436 187
4c4b4cd2
PH
188static struct value *coerce_unspec_val_to_type (struct value *,
189 struct type *);
14f9c5c9 190
d2e4a39e 191static struct value *get_var_value (char *, char *);
14f9c5c9 192
d2e4a39e 193static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 194
d2e4a39e 195static int equiv_types (struct type *, struct type *);
14f9c5c9 196
d2e4a39e 197static int is_name_suffix (const char *);
14f9c5c9 198
73589123
PH
199static int advance_wild_match (const char **, const char *, int);
200
201static int wild_match (const char *, const char *);
14f9c5c9 202
d2e4a39e 203static struct value *ada_coerce_ref (struct value *);
14f9c5c9 204
4c4b4cd2
PH
205static LONGEST pos_atr (struct value *);
206
3cb382c9 207static struct value *value_pos_atr (struct type *, struct value *);
14f9c5c9 208
d2e4a39e 209static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 210
4c4b4cd2
PH
211static struct symbol *standard_lookup (const char *, const struct block *,
212 domain_enum);
14f9c5c9 213
4c4b4cd2
PH
214static struct value *ada_search_struct_field (char *, struct value *, int,
215 struct type *);
216
217static struct value *ada_value_primitive_field (struct value *, int, int,
218 struct type *);
219
0d5cff50 220static int find_struct_field (const char *, struct type *, int,
52ce6436 221 struct type **, int *, int *, int *, int *);
4c4b4cd2
PH
222
223static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
224 struct value *);
225
d12307c1 226static int ada_resolve_function (struct block_symbol *, int,
4c4b4cd2
PH
227 struct value **, int, const char *,
228 struct type *);
229
4c4b4cd2
PH
230static int ada_is_direct_array_type (struct type *);
231
72d5681a
PH
232static void ada_language_arch_info (struct gdbarch *,
233 struct language_arch_info *);
714e53ab 234
52ce6436
PH
235static struct value *ada_index_struct_field (int, struct value *, int,
236 struct type *);
237
238static struct value *assign_aggregate (struct value *, struct value *,
0963b4bd
MS
239 struct expression *,
240 int *, enum noside);
52ce6436
PH
241
242static void aggregate_assign_from_choices (struct value *, struct value *,
243 struct expression *,
244 int *, LONGEST *, int *,
245 int, LONGEST, LONGEST);
246
247static void aggregate_assign_positional (struct value *, struct value *,
248 struct expression *,
249 int *, LONGEST *, int *, int,
250 LONGEST, LONGEST);
251
252
253static void aggregate_assign_others (struct value *, struct value *,
254 struct expression *,
255 int *, LONGEST *, int, LONGEST, LONGEST);
256
257
258static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
259
260
261static struct value *ada_evaluate_subexp (struct type *, struct expression *,
262 int *, enum noside);
263
264static void ada_forward_operator_length (struct expression *, int, int *,
265 int *);
852dff6c
JB
266
267static struct type *ada_find_any_type (const char *name);
4c4b4cd2
PH
268\f
269
ee01b665
JB
270/* The result of a symbol lookup to be stored in our symbol cache. */
271
272struct cache_entry
273{
274 /* The name used to perform the lookup. */
275 const char *name;
276 /* The namespace used during the lookup. */
fe978cb0 277 domain_enum domain;
ee01b665
JB
278 /* The symbol returned by the lookup, or NULL if no matching symbol
279 was found. */
280 struct symbol *sym;
281 /* The block where the symbol was found, or NULL if no matching
282 symbol was found. */
283 const struct block *block;
284 /* A pointer to the next entry with the same hash. */
285 struct cache_entry *next;
286};
287
288/* The Ada symbol cache, used to store the result of Ada-mode symbol
289 lookups in the course of executing the user's commands.
290
291 The cache is implemented using a simple, fixed-sized hash.
292 The size is fixed on the grounds that there are not likely to be
293 all that many symbols looked up during any given session, regardless
294 of the size of the symbol table. If we decide to go to a resizable
295 table, let's just use the stuff from libiberty instead. */
296
297#define HASH_SIZE 1009
298
299struct ada_symbol_cache
300{
301 /* An obstack used to store the entries in our cache. */
302 struct obstack cache_space;
303
304 /* The root of the hash table used to implement our symbol cache. */
305 struct cache_entry *root[HASH_SIZE];
306};
307
308static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
76a01679 309
4c4b4cd2 310/* Maximum-sized dynamic type. */
14f9c5c9
AS
311static unsigned int varsize_limit;
312
4c4b4cd2
PH
313/* FIXME: brobecker/2003-09-17: No longer a const because it is
314 returned by a function that does not return a const char *. */
315static char *ada_completer_word_break_characters =
316#ifdef VMS
317 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
318#else
14f9c5c9 319 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 320#endif
14f9c5c9 321
4c4b4cd2 322/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 323static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 324 = "__gnat_ada_main_program_name";
14f9c5c9 325
4c4b4cd2
PH
326/* Limit on the number of warnings to raise per expression evaluation. */
327static int warning_limit = 2;
328
329/* Number of warning messages issued; reset to 0 by cleanups after
330 expression evaluation. */
331static int warnings_issued = 0;
332
333static const char *known_runtime_file_name_patterns[] = {
334 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
335};
336
337static const char *known_auxiliary_function_name_patterns[] = {
338 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
339};
340
341/* Space for allocating results of ada_lookup_symbol_list. */
342static struct obstack symbol_list_obstack;
343
c6044dd1
JB
344/* Maintenance-related settings for this module. */
345
346static struct cmd_list_element *maint_set_ada_cmdlist;
347static struct cmd_list_element *maint_show_ada_cmdlist;
348
349/* Implement the "maintenance set ada" (prefix) command. */
350
351static void
352maint_set_ada_cmd (char *args, int from_tty)
353{
635c7e8a
TT
354 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
355 gdb_stdout);
c6044dd1
JB
356}
357
358/* Implement the "maintenance show ada" (prefix) command. */
359
360static void
361maint_show_ada_cmd (char *args, int from_tty)
362{
363 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
364}
365
366/* The "maintenance ada set/show ignore-descriptive-type" value. */
367
368static int ada_ignore_descriptive_types_p = 0;
369
e802dbe0
JB
370 /* Inferior-specific data. */
371
372/* Per-inferior data for this module. */
373
374struct ada_inferior_data
375{
376 /* The ada__tags__type_specific_data type, which is used when decoding
377 tagged types. With older versions of GNAT, this type was directly
378 accessible through a component ("tsd") in the object tag. But this
379 is no longer the case, so we cache it for each inferior. */
380 struct type *tsd_type;
3eecfa55
JB
381
382 /* The exception_support_info data. This data is used to determine
383 how to implement support for Ada exception catchpoints in a given
384 inferior. */
385 const struct exception_support_info *exception_info;
e802dbe0
JB
386};
387
388/* Our key to this module's inferior data. */
389static const struct inferior_data *ada_inferior_data;
390
391/* A cleanup routine for our inferior data. */
392static void
393ada_inferior_data_cleanup (struct inferior *inf, void *arg)
394{
395 struct ada_inferior_data *data;
396
397 data = inferior_data (inf, ada_inferior_data);
398 if (data != NULL)
399 xfree (data);
400}
401
402/* Return our inferior data for the given inferior (INF).
403
404 This function always returns a valid pointer to an allocated
405 ada_inferior_data structure. If INF's inferior data has not
406 been previously set, this functions creates a new one with all
407 fields set to zero, sets INF's inferior to it, and then returns
408 a pointer to that newly allocated ada_inferior_data. */
409
410static struct ada_inferior_data *
411get_ada_inferior_data (struct inferior *inf)
412{
413 struct ada_inferior_data *data;
414
415 data = inferior_data (inf, ada_inferior_data);
416 if (data == NULL)
417 {
41bf6aca 418 data = XCNEW (struct ada_inferior_data);
e802dbe0
JB
419 set_inferior_data (inf, ada_inferior_data, data);
420 }
421
422 return data;
423}
424
425/* Perform all necessary cleanups regarding our module's inferior data
426 that is required after the inferior INF just exited. */
427
428static void
429ada_inferior_exit (struct inferior *inf)
430{
431 ada_inferior_data_cleanup (inf, NULL);
432 set_inferior_data (inf, ada_inferior_data, NULL);
433}
434
ee01b665
JB
435
436 /* program-space-specific data. */
437
438/* This module's per-program-space data. */
439struct ada_pspace_data
440{
441 /* The Ada symbol cache. */
442 struct ada_symbol_cache *sym_cache;
443};
444
445/* Key to our per-program-space data. */
446static const struct program_space_data *ada_pspace_data_handle;
447
448/* Return this module's data for the given program space (PSPACE).
449 If not is found, add a zero'ed one now.
450
451 This function always returns a valid object. */
452
453static struct ada_pspace_data *
454get_ada_pspace_data (struct program_space *pspace)
455{
456 struct ada_pspace_data *data;
457
458 data = program_space_data (pspace, ada_pspace_data_handle);
459 if (data == NULL)
460 {
461 data = XCNEW (struct ada_pspace_data);
462 set_program_space_data (pspace, ada_pspace_data_handle, data);
463 }
464
465 return data;
466}
467
468/* The cleanup callback for this module's per-program-space data. */
469
470static void
471ada_pspace_data_cleanup (struct program_space *pspace, void *data)
472{
473 struct ada_pspace_data *pspace_data = data;
474
475 if (pspace_data->sym_cache != NULL)
476 ada_free_symbol_cache (pspace_data->sym_cache);
477 xfree (pspace_data);
478}
479
4c4b4cd2
PH
480 /* Utilities */
481
720d1a40 482/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
eed9788b 483 all typedef layers have been peeled. Otherwise, return TYPE.
720d1a40
JB
484
485 Normally, we really expect a typedef type to only have 1 typedef layer.
486 In other words, we really expect the target type of a typedef type to be
487 a non-typedef type. This is particularly true for Ada units, because
488 the language does not have a typedef vs not-typedef distinction.
489 In that respect, the Ada compiler has been trying to eliminate as many
490 typedef definitions in the debugging information, since they generally
491 do not bring any extra information (we still use typedef under certain
492 circumstances related mostly to the GNAT encoding).
493
494 Unfortunately, we have seen situations where the debugging information
495 generated by the compiler leads to such multiple typedef layers. For
496 instance, consider the following example with stabs:
497
498 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
499 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
500
501 This is an error in the debugging information which causes type
502 pck__float_array___XUP to be defined twice, and the second time,
503 it is defined as a typedef of a typedef.
504
505 This is on the fringe of legality as far as debugging information is
506 concerned, and certainly unexpected. But it is easy to handle these
507 situations correctly, so we can afford to be lenient in this case. */
508
509static struct type *
510ada_typedef_target_type (struct type *type)
511{
512 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
513 type = TYPE_TARGET_TYPE (type);
514 return type;
515}
516
41d27058
JB
517/* Given DECODED_NAME a string holding a symbol name in its
518 decoded form (ie using the Ada dotted notation), returns
519 its unqualified name. */
520
521static const char *
522ada_unqualified_name (const char *decoded_name)
523{
2b0f535a
JB
524 const char *result;
525
526 /* If the decoded name starts with '<', it means that the encoded
527 name does not follow standard naming conventions, and thus that
528 it is not your typical Ada symbol name. Trying to unqualify it
529 is therefore pointless and possibly erroneous. */
530 if (decoded_name[0] == '<')
531 return decoded_name;
532
533 result = strrchr (decoded_name, '.');
41d27058
JB
534 if (result != NULL)
535 result++; /* Skip the dot... */
536 else
537 result = decoded_name;
538
539 return result;
540}
541
542/* Return a string starting with '<', followed by STR, and '>'.
543 The result is good until the next call. */
544
545static char *
546add_angle_brackets (const char *str)
547{
548 static char *result = NULL;
549
550 xfree (result);
88c15c34 551 result = xstrprintf ("<%s>", str);
41d27058
JB
552 return result;
553}
96d887e8 554
4c4b4cd2
PH
555static char *
556ada_get_gdb_completer_word_break_characters (void)
557{
558 return ada_completer_word_break_characters;
559}
560
e79af960
JB
561/* Print an array element index using the Ada syntax. */
562
563static void
564ada_print_array_index (struct value *index_value, struct ui_file *stream,
79a45b7d 565 const struct value_print_options *options)
e79af960 566{
79a45b7d 567 LA_VALUE_PRINT (index_value, stream, options);
e79af960
JB
568 fprintf_filtered (stream, " => ");
569}
570
f27cf670 571/* Assuming VECT points to an array of *SIZE objects of size
14f9c5c9 572 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
f27cf670 573 updating *SIZE as necessary and returning the (new) array. */
14f9c5c9 574
f27cf670
AS
575void *
576grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
14f9c5c9 577{
d2e4a39e
AS
578 if (*size < min_size)
579 {
580 *size *= 2;
581 if (*size < min_size)
4c4b4cd2 582 *size = min_size;
f27cf670 583 vect = xrealloc (vect, *size * element_size);
d2e4a39e 584 }
f27cf670 585 return vect;
14f9c5c9
AS
586}
587
588/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 589 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
590
591static int
ebf56fd3 592field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
593{
594 int len = strlen (target);
5b4ee69b 595
d2e4a39e 596 return
4c4b4cd2
PH
597 (strncmp (field_name, target, len) == 0
598 && (field_name[len] == '\0'
61012eef 599 || (startswith (field_name + len, "___")
76a01679
JB
600 && strcmp (field_name + strlen (field_name) - 6,
601 "___XVN") != 0)));
14f9c5c9
AS
602}
603
604
872c8b51
JB
605/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
606 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
607 and return its index. This function also handles fields whose name
608 have ___ suffixes because the compiler sometimes alters their name
609 by adding such a suffix to represent fields with certain constraints.
610 If the field could not be found, return a negative number if
611 MAYBE_MISSING is set. Otherwise raise an error. */
4c4b4cd2
PH
612
613int
614ada_get_field_index (const struct type *type, const char *field_name,
615 int maybe_missing)
616{
617 int fieldno;
872c8b51
JB
618 struct type *struct_type = check_typedef ((struct type *) type);
619
620 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
621 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
4c4b4cd2
PH
622 return fieldno;
623
624 if (!maybe_missing)
323e0a4a 625 error (_("Unable to find field %s in struct %s. Aborting"),
872c8b51 626 field_name, TYPE_NAME (struct_type));
4c4b4cd2
PH
627
628 return -1;
629}
630
631/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
632
633int
d2e4a39e 634ada_name_prefix_len (const char *name)
14f9c5c9
AS
635{
636 if (name == NULL)
637 return 0;
d2e4a39e 638 else
14f9c5c9 639 {
d2e4a39e 640 const char *p = strstr (name, "___");
5b4ee69b 641
14f9c5c9 642 if (p == NULL)
4c4b4cd2 643 return strlen (name);
14f9c5c9 644 else
4c4b4cd2 645 return p - name;
14f9c5c9
AS
646 }
647}
648
4c4b4cd2
PH
649/* Return non-zero if SUFFIX is a suffix of STR.
650 Return zero if STR is null. */
651
14f9c5c9 652static int
d2e4a39e 653is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
654{
655 int len1, len2;
5b4ee69b 656
14f9c5c9
AS
657 if (str == NULL)
658 return 0;
659 len1 = strlen (str);
660 len2 = strlen (suffix);
4c4b4cd2 661 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
662}
663
4c4b4cd2
PH
664/* The contents of value VAL, treated as a value of type TYPE. The
665 result is an lval in memory if VAL is. */
14f9c5c9 666
d2e4a39e 667static struct value *
4c4b4cd2 668coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9 669{
61ee279c 670 type = ada_check_typedef (type);
df407dfe 671 if (value_type (val) == type)
4c4b4cd2 672 return val;
d2e4a39e 673 else
14f9c5c9 674 {
4c4b4cd2
PH
675 struct value *result;
676
677 /* Make sure that the object size is not unreasonable before
678 trying to allocate some memory for it. */
c1b5a1a6 679 ada_ensure_varsize_limit (type);
4c4b4cd2 680
41e8491f
JK
681 if (value_lazy (val)
682 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
683 result = allocate_value_lazy (type);
684 else
685 {
686 result = allocate_value (type);
9a0dc9e3 687 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
41e8491f 688 }
74bcbdf3 689 set_value_component_location (result, val);
9bbda503
AC
690 set_value_bitsize (result, value_bitsize (val));
691 set_value_bitpos (result, value_bitpos (val));
42ae5230 692 set_value_address (result, value_address (val));
14f9c5c9
AS
693 return result;
694 }
695}
696
fc1a4b47
AC
697static const gdb_byte *
698cond_offset_host (const gdb_byte *valaddr, long offset)
14f9c5c9
AS
699{
700 if (valaddr == NULL)
701 return NULL;
702 else
703 return valaddr + offset;
704}
705
706static CORE_ADDR
ebf56fd3 707cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
708{
709 if (address == 0)
710 return 0;
d2e4a39e 711 else
14f9c5c9
AS
712 return address + offset;
713}
714
4c4b4cd2
PH
715/* Issue a warning (as for the definition of warning in utils.c, but
716 with exactly one argument rather than ...), unless the limit on the
717 number of warnings has passed during the evaluation of the current
718 expression. */
a2249542 719
77109804
AC
720/* FIXME: cagney/2004-10-10: This function is mimicking the behavior
721 provided by "complaint". */
a0b31db1 722static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
77109804 723
14f9c5c9 724static void
a2249542 725lim_warning (const char *format, ...)
14f9c5c9 726{
a2249542 727 va_list args;
a2249542 728
5b4ee69b 729 va_start (args, format);
4c4b4cd2
PH
730 warnings_issued += 1;
731 if (warnings_issued <= warning_limit)
a2249542
MK
732 vwarning (format, args);
733
734 va_end (args);
4c4b4cd2
PH
735}
736
714e53ab
PH
737/* Issue an error if the size of an object of type T is unreasonable,
738 i.e. if it would be a bad idea to allocate a value of this type in
739 GDB. */
740
c1b5a1a6
JB
741void
742ada_ensure_varsize_limit (const struct type *type)
714e53ab
PH
743{
744 if (TYPE_LENGTH (type) > varsize_limit)
323e0a4a 745 error (_("object size is larger than varsize-limit"));
714e53ab
PH
746}
747
0963b4bd 748/* Maximum value of a SIZE-byte signed integer type. */
4c4b4cd2 749static LONGEST
c3e5cd34 750max_of_size (int size)
4c4b4cd2 751{
76a01679 752 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
5b4ee69b 753
76a01679 754 return top_bit | (top_bit - 1);
4c4b4cd2
PH
755}
756
0963b4bd 757/* Minimum value of a SIZE-byte signed integer type. */
4c4b4cd2 758static LONGEST
c3e5cd34 759min_of_size (int size)
4c4b4cd2 760{
c3e5cd34 761 return -max_of_size (size) - 1;
4c4b4cd2
PH
762}
763
0963b4bd 764/* Maximum value of a SIZE-byte unsigned integer type. */
4c4b4cd2 765static ULONGEST
c3e5cd34 766umax_of_size (int size)
4c4b4cd2 767{
76a01679 768 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
5b4ee69b 769
76a01679 770 return top_bit | (top_bit - 1);
4c4b4cd2
PH
771}
772
0963b4bd 773/* Maximum value of integral type T, as a signed quantity. */
c3e5cd34
PH
774static LONGEST
775max_of_type (struct type *t)
4c4b4cd2 776{
c3e5cd34
PH
777 if (TYPE_UNSIGNED (t))
778 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
779 else
780 return max_of_size (TYPE_LENGTH (t));
781}
782
0963b4bd 783/* Minimum value of integral type T, as a signed quantity. */
c3e5cd34
PH
784static LONGEST
785min_of_type (struct type *t)
786{
787 if (TYPE_UNSIGNED (t))
788 return 0;
789 else
790 return min_of_size (TYPE_LENGTH (t));
4c4b4cd2
PH
791}
792
793/* The largest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
794LONGEST
795ada_discrete_type_high_bound (struct type *type)
4c4b4cd2 796{
c3345124 797 type = resolve_dynamic_type (type, NULL, 0);
76a01679 798 switch (TYPE_CODE (type))
4c4b4cd2
PH
799 {
800 case TYPE_CODE_RANGE:
690cc4eb 801 return TYPE_HIGH_BOUND (type);
4c4b4cd2 802 case TYPE_CODE_ENUM:
14e75d8e 803 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
690cc4eb
PH
804 case TYPE_CODE_BOOL:
805 return 1;
806 case TYPE_CODE_CHAR:
76a01679 807 case TYPE_CODE_INT:
690cc4eb 808 return max_of_type (type);
4c4b4cd2 809 default:
43bbcdc2 810 error (_("Unexpected type in ada_discrete_type_high_bound."));
4c4b4cd2
PH
811 }
812}
813
14e75d8e 814/* The smallest value in the domain of TYPE, a discrete type, as an integer. */
43bbcdc2
PH
815LONGEST
816ada_discrete_type_low_bound (struct type *type)
4c4b4cd2 817{
c3345124 818 type = resolve_dynamic_type (type, NULL, 0);
76a01679 819 switch (TYPE_CODE (type))
4c4b4cd2
PH
820 {
821 case TYPE_CODE_RANGE:
690cc4eb 822 return TYPE_LOW_BOUND (type);
4c4b4cd2 823 case TYPE_CODE_ENUM:
14e75d8e 824 return TYPE_FIELD_ENUMVAL (type, 0);
690cc4eb
PH
825 case TYPE_CODE_BOOL:
826 return 0;
827 case TYPE_CODE_CHAR:
76a01679 828 case TYPE_CODE_INT:
690cc4eb 829 return min_of_type (type);
4c4b4cd2 830 default:
43bbcdc2 831 error (_("Unexpected type in ada_discrete_type_low_bound."));
4c4b4cd2
PH
832 }
833}
834
835/* The identity on non-range types. For range types, the underlying
76a01679 836 non-range scalar type. */
4c4b4cd2
PH
837
838static struct type *
18af8284 839get_base_type (struct type *type)
4c4b4cd2
PH
840{
841 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
842 {
76a01679
JB
843 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
844 return type;
4c4b4cd2
PH
845 type = TYPE_TARGET_TYPE (type);
846 }
847 return type;
14f9c5c9 848}
41246937
JB
849
850/* Return a decoded version of the given VALUE. This means returning
851 a value whose type is obtained by applying all the GNAT-specific
852 encondings, making the resulting type a static but standard description
853 of the initial type. */
854
855struct value *
856ada_get_decoded_value (struct value *value)
857{
858 struct type *type = ada_check_typedef (value_type (value));
859
860 if (ada_is_array_descriptor_type (type)
861 || (ada_is_constrained_packed_array_type (type)
862 && TYPE_CODE (type) != TYPE_CODE_PTR))
863 {
864 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
865 value = ada_coerce_to_simple_array_ptr (value);
866 else
867 value = ada_coerce_to_simple_array (value);
868 }
869 else
870 value = ada_to_fixed_value (value);
871
872 return value;
873}
874
875/* Same as ada_get_decoded_value, but with the given TYPE.
876 Because there is no associated actual value for this type,
877 the resulting type might be a best-effort approximation in
878 the case of dynamic types. */
879
880struct type *
881ada_get_decoded_type (struct type *type)
882{
883 type = to_static_fixed_type (type);
884 if (ada_is_constrained_packed_array_type (type))
885 type = ada_coerce_to_simple_array_type (type);
886 return type;
887}
888
4c4b4cd2 889\f
76a01679 890
4c4b4cd2 891 /* Language Selection */
14f9c5c9
AS
892
893/* If the main program is in Ada, return language_ada, otherwise return LANG
ccefe4c4 894 (the main program is in Ada iif the adainit symbol is found). */
d2e4a39e 895
14f9c5c9 896enum language
ccefe4c4 897ada_update_initial_language (enum language lang)
14f9c5c9 898{
d2e4a39e 899 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
3b7344d5 900 (struct objfile *) NULL).minsym != NULL)
4c4b4cd2 901 return language_ada;
14f9c5c9
AS
902
903 return lang;
904}
96d887e8
PH
905
906/* If the main procedure is written in Ada, then return its name.
907 The result is good until the next call. Return NULL if the main
908 procedure doesn't appear to be in Ada. */
909
910char *
911ada_main_name (void)
912{
3b7344d5 913 struct bound_minimal_symbol msym;
f9bc20b9 914 static char *main_program_name = NULL;
6c038f32 915
96d887e8
PH
916 /* For Ada, the name of the main procedure is stored in a specific
917 string constant, generated by the binder. Look for that symbol,
918 extract its address, and then read that string. If we didn't find
919 that string, then most probably the main procedure is not written
920 in Ada. */
921 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
922
3b7344d5 923 if (msym.minsym != NULL)
96d887e8 924 {
f9bc20b9
JB
925 CORE_ADDR main_program_name_addr;
926 int err_code;
927
77e371c0 928 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
96d887e8 929 if (main_program_name_addr == 0)
323e0a4a 930 error (_("Invalid address for Ada main program name."));
96d887e8 931
f9bc20b9
JB
932 xfree (main_program_name);
933 target_read_string (main_program_name_addr, &main_program_name,
934 1024, &err_code);
935
936 if (err_code != 0)
937 return NULL;
96d887e8
PH
938 return main_program_name;
939 }
940
941 /* The main procedure doesn't seem to be in Ada. */
942 return NULL;
943}
14f9c5c9 944\f
4c4b4cd2 945 /* Symbols */
d2e4a39e 946
4c4b4cd2
PH
947/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
948 of NULLs. */
14f9c5c9 949
d2e4a39e
AS
950const struct ada_opname_map ada_opname_table[] = {
951 {"Oadd", "\"+\"", BINOP_ADD},
952 {"Osubtract", "\"-\"", BINOP_SUB},
953 {"Omultiply", "\"*\"", BINOP_MUL},
954 {"Odivide", "\"/\"", BINOP_DIV},
955 {"Omod", "\"mod\"", BINOP_MOD},
956 {"Orem", "\"rem\"", BINOP_REM},
957 {"Oexpon", "\"**\"", BINOP_EXP},
958 {"Olt", "\"<\"", BINOP_LESS},
959 {"Ole", "\"<=\"", BINOP_LEQ},
960 {"Ogt", "\">\"", BINOP_GTR},
961 {"Oge", "\">=\"", BINOP_GEQ},
962 {"Oeq", "\"=\"", BINOP_EQUAL},
963 {"One", "\"/=\"", BINOP_NOTEQUAL},
964 {"Oand", "\"and\"", BINOP_BITWISE_AND},
965 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
966 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
967 {"Oconcat", "\"&\"", BINOP_CONCAT},
968 {"Oabs", "\"abs\"", UNOP_ABS},
969 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
970 {"Oadd", "\"+\"", UNOP_PLUS},
971 {"Osubtract", "\"-\"", UNOP_NEG},
972 {NULL, NULL}
14f9c5c9
AS
973};
974
4c4b4cd2
PH
975/* The "encoded" form of DECODED, according to GNAT conventions.
976 The result is valid until the next call to ada_encode. */
977
14f9c5c9 978char *
4c4b4cd2 979ada_encode (const char *decoded)
14f9c5c9 980{
4c4b4cd2
PH
981 static char *encoding_buffer = NULL;
982 static size_t encoding_buffer_size = 0;
d2e4a39e 983 const char *p;
14f9c5c9 984 int k;
d2e4a39e 985
4c4b4cd2 986 if (decoded == NULL)
14f9c5c9
AS
987 return NULL;
988
4c4b4cd2
PH
989 GROW_VECT (encoding_buffer, encoding_buffer_size,
990 2 * strlen (decoded) + 10);
14f9c5c9
AS
991
992 k = 0;
4c4b4cd2 993 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 994 {
cdc7bb92 995 if (*p == '.')
4c4b4cd2
PH
996 {
997 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
998 k += 2;
999 }
14f9c5c9 1000 else if (*p == '"')
4c4b4cd2
PH
1001 {
1002 const struct ada_opname_map *mapping;
1003
1004 for (mapping = ada_opname_table;
1265e4aa 1005 mapping->encoded != NULL
61012eef 1006 && !startswith (p, mapping->decoded); mapping += 1)
4c4b4cd2
PH
1007 ;
1008 if (mapping->encoded == NULL)
323e0a4a 1009 error (_("invalid Ada operator name: %s"), p);
4c4b4cd2
PH
1010 strcpy (encoding_buffer + k, mapping->encoded);
1011 k += strlen (mapping->encoded);
1012 break;
1013 }
d2e4a39e 1014 else
4c4b4cd2
PH
1015 {
1016 encoding_buffer[k] = *p;
1017 k += 1;
1018 }
14f9c5c9
AS
1019 }
1020
4c4b4cd2
PH
1021 encoding_buffer[k] = '\0';
1022 return encoding_buffer;
14f9c5c9
AS
1023}
1024
1025/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
1026 quotes, unfolded, but with the quotes stripped away. Result good
1027 to next call. */
1028
d2e4a39e
AS
1029char *
1030ada_fold_name (const char *name)
14f9c5c9 1031{
d2e4a39e 1032 static char *fold_buffer = NULL;
14f9c5c9
AS
1033 static size_t fold_buffer_size = 0;
1034
1035 int len = strlen (name);
d2e4a39e 1036 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
1037
1038 if (name[0] == '\'')
1039 {
d2e4a39e
AS
1040 strncpy (fold_buffer, name + 1, len - 2);
1041 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
1042 }
1043 else
1044 {
1045 int i;
5b4ee69b 1046
14f9c5c9 1047 for (i = 0; i <= len; i += 1)
4c4b4cd2 1048 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
1049 }
1050
1051 return fold_buffer;
1052}
1053
529cad9c
PH
1054/* Return nonzero if C is either a digit or a lowercase alphabet character. */
1055
1056static int
1057is_lower_alphanum (const char c)
1058{
1059 return (isdigit (c) || (isalpha (c) && islower (c)));
1060}
1061
c90092fe
JB
1062/* ENCODED is the linkage name of a symbol and LEN contains its length.
1063 This function saves in LEN the length of that same symbol name but
1064 without either of these suffixes:
29480c32
JB
1065 . .{DIGIT}+
1066 . ${DIGIT}+
1067 . ___{DIGIT}+
1068 . __{DIGIT}+.
c90092fe 1069
29480c32
JB
1070 These are suffixes introduced by the compiler for entities such as
1071 nested subprogram for instance, in order to avoid name clashes.
1072 They do not serve any purpose for the debugger. */
1073
1074static void
1075ada_remove_trailing_digits (const char *encoded, int *len)
1076{
1077 if (*len > 1 && isdigit (encoded[*len - 1]))
1078 {
1079 int i = *len - 2;
5b4ee69b 1080
29480c32
JB
1081 while (i > 0 && isdigit (encoded[i]))
1082 i--;
1083 if (i >= 0 && encoded[i] == '.')
1084 *len = i;
1085 else if (i >= 0 && encoded[i] == '$')
1086 *len = i;
61012eef 1087 else if (i >= 2 && startswith (encoded + i - 2, "___"))
29480c32 1088 *len = i - 2;
61012eef 1089 else if (i >= 1 && startswith (encoded + i - 1, "__"))
29480c32
JB
1090 *len = i - 1;
1091 }
1092}
1093
1094/* Remove the suffix introduced by the compiler for protected object
1095 subprograms. */
1096
1097static void
1098ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1099{
1100 /* Remove trailing N. */
1101
1102 /* Protected entry subprograms are broken into two
1103 separate subprograms: The first one is unprotected, and has
1104 a 'N' suffix; the second is the protected version, and has
0963b4bd 1105 the 'P' suffix. The second calls the first one after handling
29480c32
JB
1106 the protection. Since the P subprograms are internally generated,
1107 we leave these names undecoded, giving the user a clue that this
1108 entity is internal. */
1109
1110 if (*len > 1
1111 && encoded[*len - 1] == 'N'
1112 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1113 *len = *len - 1;
1114}
1115
69fadcdf
JB
1116/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1117
1118static void
1119ada_remove_Xbn_suffix (const char *encoded, int *len)
1120{
1121 int i = *len - 1;
1122
1123 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1124 i--;
1125
1126 if (encoded[i] != 'X')
1127 return;
1128
1129 if (i == 0)
1130 return;
1131
1132 if (isalnum (encoded[i-1]))
1133 *len = i;
1134}
1135
29480c32
JB
1136/* If ENCODED follows the GNAT entity encoding conventions, then return
1137 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1138 replaced by ENCODED.
14f9c5c9 1139
4c4b4cd2 1140 The resulting string is valid until the next call of ada_decode.
29480c32 1141 If the string is unchanged by decoding, the original string pointer
4c4b4cd2
PH
1142 is returned. */
1143
1144const char *
1145ada_decode (const char *encoded)
14f9c5c9
AS
1146{
1147 int i, j;
1148 int len0;
d2e4a39e 1149 const char *p;
4c4b4cd2 1150 char *decoded;
14f9c5c9 1151 int at_start_name;
4c4b4cd2
PH
1152 static char *decoding_buffer = NULL;
1153 static size_t decoding_buffer_size = 0;
d2e4a39e 1154
29480c32
JB
1155 /* The name of the Ada main procedure starts with "_ada_".
1156 This prefix is not part of the decoded name, so skip this part
1157 if we see this prefix. */
61012eef 1158 if (startswith (encoded, "_ada_"))
4c4b4cd2 1159 encoded += 5;
14f9c5c9 1160
29480c32
JB
1161 /* If the name starts with '_', then it is not a properly encoded
1162 name, so do not attempt to decode it. Similarly, if the name
1163 starts with '<', the name should not be decoded. */
4c4b4cd2 1164 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
1165 goto Suppress;
1166
4c4b4cd2 1167 len0 = strlen (encoded);
4c4b4cd2 1168
29480c32
JB
1169 ada_remove_trailing_digits (encoded, &len0);
1170 ada_remove_po_subprogram_suffix (encoded, &len0);
529cad9c 1171
4c4b4cd2
PH
1172 /* Remove the ___X.* suffix if present. Do not forget to verify that
1173 the suffix is located before the current "end" of ENCODED. We want
1174 to avoid re-matching parts of ENCODED that have previously been
1175 marked as discarded (by decrementing LEN0). */
1176 p = strstr (encoded, "___");
1177 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
1178 {
1179 if (p[3] == 'X')
4c4b4cd2 1180 len0 = p - encoded;
14f9c5c9 1181 else
4c4b4cd2 1182 goto Suppress;
14f9c5c9 1183 }
4c4b4cd2 1184
29480c32
JB
1185 /* Remove any trailing TKB suffix. It tells us that this symbol
1186 is for the body of a task, but that information does not actually
1187 appear in the decoded name. */
1188
61012eef 1189 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
14f9c5c9 1190 len0 -= 3;
76a01679 1191
a10967fa
JB
1192 /* Remove any trailing TB suffix. The TB suffix is slightly different
1193 from the TKB suffix because it is used for non-anonymous task
1194 bodies. */
1195
61012eef 1196 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
a10967fa
JB
1197 len0 -= 2;
1198
29480c32
JB
1199 /* Remove trailing "B" suffixes. */
1200 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1201
61012eef 1202 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
14f9c5c9
AS
1203 len0 -= 1;
1204
4c4b4cd2 1205 /* Make decoded big enough for possible expansion by operator name. */
29480c32 1206
4c4b4cd2
PH
1207 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1208 decoded = decoding_buffer;
14f9c5c9 1209
29480c32
JB
1210 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1211
4c4b4cd2 1212 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 1213 {
4c4b4cd2
PH
1214 i = len0 - 2;
1215 while ((i >= 0 && isdigit (encoded[i]))
1216 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1217 i -= 1;
1218 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1219 len0 = i - 1;
1220 else if (encoded[i] == '$')
1221 len0 = i;
d2e4a39e 1222 }
14f9c5c9 1223
29480c32
JB
1224 /* The first few characters that are not alphabetic are not part
1225 of any encoding we use, so we can copy them over verbatim. */
1226
4c4b4cd2
PH
1227 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1228 decoded[j] = encoded[i];
14f9c5c9
AS
1229
1230 at_start_name = 1;
1231 while (i < len0)
1232 {
29480c32 1233 /* Is this a symbol function? */
4c4b4cd2
PH
1234 if (at_start_name && encoded[i] == 'O')
1235 {
1236 int k;
5b4ee69b 1237
4c4b4cd2
PH
1238 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1239 {
1240 int op_len = strlen (ada_opname_table[k].encoded);
06d5cf63
JB
1241 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1242 op_len - 1) == 0)
1243 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
1244 {
1245 strcpy (decoded + j, ada_opname_table[k].decoded);
1246 at_start_name = 0;
1247 i += op_len;
1248 j += strlen (ada_opname_table[k].decoded);
1249 break;
1250 }
1251 }
1252 if (ada_opname_table[k].encoded != NULL)
1253 continue;
1254 }
14f9c5c9
AS
1255 at_start_name = 0;
1256
529cad9c
PH
1257 /* Replace "TK__" with "__", which will eventually be translated
1258 into "." (just below). */
1259
61012eef 1260 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
4c4b4cd2 1261 i += 2;
529cad9c 1262
29480c32
JB
1263 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1264 be translated into "." (just below). These are internal names
1265 generated for anonymous blocks inside which our symbol is nested. */
1266
1267 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1268 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1269 && isdigit (encoded [i+4]))
1270 {
1271 int k = i + 5;
1272
1273 while (k < len0 && isdigit (encoded[k]))
1274 k++; /* Skip any extra digit. */
1275
1276 /* Double-check that the "__B_{DIGITS}+" sequence we found
1277 is indeed followed by "__". */
1278 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1279 i = k;
1280 }
1281
529cad9c
PH
1282 /* Remove _E{DIGITS}+[sb] */
1283
1284 /* Just as for protected object subprograms, there are 2 categories
0963b4bd 1285 of subprograms created by the compiler for each entry. The first
529cad9c
PH
1286 one implements the actual entry code, and has a suffix following
1287 the convention above; the second one implements the barrier and
1288 uses the same convention as above, except that the 'E' is replaced
1289 by a 'B'.
1290
1291 Just as above, we do not decode the name of barrier functions
1292 to give the user a clue that the code he is debugging has been
1293 internally generated. */
1294
1295 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1296 && isdigit (encoded[i+2]))
1297 {
1298 int k = i + 3;
1299
1300 while (k < len0 && isdigit (encoded[k]))
1301 k++;
1302
1303 if (k < len0
1304 && (encoded[k] == 'b' || encoded[k] == 's'))
1305 {
1306 k++;
1307 /* Just as an extra precaution, make sure that if this
1308 suffix is followed by anything else, it is a '_'.
1309 Otherwise, we matched this sequence by accident. */
1310 if (k == len0
1311 || (k < len0 && encoded[k] == '_'))
1312 i = k;
1313 }
1314 }
1315
1316 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1317 the GNAT front-end in protected object subprograms. */
1318
1319 if (i < len0 + 3
1320 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1321 {
1322 /* Backtrack a bit up until we reach either the begining of
1323 the encoded name, or "__". Make sure that we only find
1324 digits or lowercase characters. */
1325 const char *ptr = encoded + i - 1;
1326
1327 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1328 ptr--;
1329 if (ptr < encoded
1330 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1331 i++;
1332 }
1333
4c4b4cd2
PH
1334 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1335 {
29480c32
JB
1336 /* This is a X[bn]* sequence not separated from the previous
1337 part of the name with a non-alpha-numeric character (in other
1338 words, immediately following an alpha-numeric character), then
1339 verify that it is placed at the end of the encoded name. If
1340 not, then the encoding is not valid and we should abort the
1341 decoding. Otherwise, just skip it, it is used in body-nested
1342 package names. */
4c4b4cd2
PH
1343 do
1344 i += 1;
1345 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1346 if (i < len0)
1347 goto Suppress;
1348 }
cdc7bb92 1349 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
4c4b4cd2 1350 {
29480c32 1351 /* Replace '__' by '.'. */
4c4b4cd2
PH
1352 decoded[j] = '.';
1353 at_start_name = 1;
1354 i += 2;
1355 j += 1;
1356 }
14f9c5c9 1357 else
4c4b4cd2 1358 {
29480c32
JB
1359 /* It's a character part of the decoded name, so just copy it
1360 over. */
4c4b4cd2
PH
1361 decoded[j] = encoded[i];
1362 i += 1;
1363 j += 1;
1364 }
14f9c5c9 1365 }
4c4b4cd2 1366 decoded[j] = '\000';
14f9c5c9 1367
29480c32
JB
1368 /* Decoded names should never contain any uppercase character.
1369 Double-check this, and abort the decoding if we find one. */
1370
4c4b4cd2
PH
1371 for (i = 0; decoded[i] != '\0'; i += 1)
1372 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1373 goto Suppress;
1374
4c4b4cd2
PH
1375 if (strcmp (decoded, encoded) == 0)
1376 return encoded;
1377 else
1378 return decoded;
14f9c5c9
AS
1379
1380Suppress:
4c4b4cd2
PH
1381 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1382 decoded = decoding_buffer;
1383 if (encoded[0] == '<')
1384 strcpy (decoded, encoded);
14f9c5c9 1385 else
88c15c34 1386 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
4c4b4cd2
PH
1387 return decoded;
1388
1389}
1390
1391/* Table for keeping permanent unique copies of decoded names. Once
1392 allocated, names in this table are never released. While this is a
1393 storage leak, it should not be significant unless there are massive
1394 changes in the set of decoded names in successive versions of a
1395 symbol table loaded during a single session. */
1396static struct htab *decoded_names_store;
1397
1398/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1399 in the language-specific part of GSYMBOL, if it has not been
1400 previously computed. Tries to save the decoded name in the same
1401 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1402 in any case, the decoded symbol has a lifetime at least that of
0963b4bd 1403 GSYMBOL).
4c4b4cd2
PH
1404 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1405 const, but nevertheless modified to a semantically equivalent form
0963b4bd 1406 when a decoded name is cached in it. */
4c4b4cd2 1407
45e6c716 1408const char *
f85f34ed 1409ada_decode_symbol (const struct general_symbol_info *arg)
4c4b4cd2 1410{
f85f34ed
TT
1411 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1412 const char **resultp =
1413 &gsymbol->language_specific.mangled_lang.demangled_name;
5b4ee69b 1414
f85f34ed 1415 if (!gsymbol->ada_mangled)
4c4b4cd2
PH
1416 {
1417 const char *decoded = ada_decode (gsymbol->name);
f85f34ed 1418 struct obstack *obstack = gsymbol->language_specific.obstack;
5b4ee69b 1419
f85f34ed 1420 gsymbol->ada_mangled = 1;
5b4ee69b 1421
f85f34ed
TT
1422 if (obstack != NULL)
1423 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1424 else
76a01679 1425 {
f85f34ed
TT
1426 /* Sometimes, we can't find a corresponding objfile, in
1427 which case, we put the result on the heap. Since we only
1428 decode when needed, we hope this usually does not cause a
1429 significant memory leak (FIXME). */
1430
76a01679
JB
1431 char **slot = (char **) htab_find_slot (decoded_names_store,
1432 decoded, INSERT);
5b4ee69b 1433
76a01679
JB
1434 if (*slot == NULL)
1435 *slot = xstrdup (decoded);
1436 *resultp = *slot;
1437 }
4c4b4cd2 1438 }
14f9c5c9 1439
4c4b4cd2
PH
1440 return *resultp;
1441}
76a01679 1442
2c0b251b 1443static char *
76a01679 1444ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1445{
1446 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1447}
1448
1449/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1450 suffixes that encode debugging information or leading _ada_ on
1451 SYM_NAME (see is_name_suffix commentary for the debugging
1452 information that is ignored). If WILD, then NAME need only match a
1453 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1454 either argument is NULL. */
14f9c5c9 1455
2c0b251b 1456static int
40658b94 1457match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1458{
1459 if (sym_name == NULL || name == NULL)
1460 return 0;
1461 else if (wild)
73589123 1462 return wild_match (sym_name, name) == 0;
d2e4a39e
AS
1463 else
1464 {
1465 int len_name = strlen (name);
5b4ee69b 1466
4c4b4cd2
PH
1467 return (strncmp (sym_name, name, len_name) == 0
1468 && is_name_suffix (sym_name + len_name))
61012eef 1469 || (startswith (sym_name, "_ada_")
4c4b4cd2
PH
1470 && strncmp (sym_name + 5, name, len_name) == 0
1471 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1472 }
14f9c5c9 1473}
14f9c5c9 1474\f
d2e4a39e 1475
4c4b4cd2 1476 /* Arrays */
14f9c5c9 1477
28c85d6c
JB
1478/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1479 generated by the GNAT compiler to describe the index type used
1480 for each dimension of an array, check whether it follows the latest
1481 known encoding. If not, fix it up to conform to the latest encoding.
1482 Otherwise, do nothing. This function also does nothing if
1483 INDEX_DESC_TYPE is NULL.
1484
1485 The GNAT encoding used to describle the array index type evolved a bit.
1486 Initially, the information would be provided through the name of each
1487 field of the structure type only, while the type of these fields was
1488 described as unspecified and irrelevant. The debugger was then expected
1489 to perform a global type lookup using the name of that field in order
1490 to get access to the full index type description. Because these global
1491 lookups can be very expensive, the encoding was later enhanced to make
1492 the global lookup unnecessary by defining the field type as being
1493 the full index type description.
1494
1495 The purpose of this routine is to allow us to support older versions
1496 of the compiler by detecting the use of the older encoding, and by
1497 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1498 we essentially replace each field's meaningless type by the associated
1499 index subtype). */
1500
1501void
1502ada_fixup_array_indexes_type (struct type *index_desc_type)
1503{
1504 int i;
1505
1506 if (index_desc_type == NULL)
1507 return;
1508 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1509
1510 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1511 to check one field only, no need to check them all). If not, return
1512 now.
1513
1514 If our INDEX_DESC_TYPE was generated using the older encoding,
1515 the field type should be a meaningless integer type whose name
1516 is not equal to the field name. */
1517 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1518 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1519 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1520 return;
1521
1522 /* Fixup each field of INDEX_DESC_TYPE. */
1523 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1524 {
0d5cff50 1525 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
28c85d6c
JB
1526 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1527
1528 if (raw_type)
1529 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1530 }
1531}
1532
4c4b4cd2 1533/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1534
d2e4a39e
AS
1535static char *bound_name[] = {
1536 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1537 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1538};
1539
1540/* Maximum number of array dimensions we are prepared to handle. */
1541
4c4b4cd2 1542#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1543
14f9c5c9 1544
4c4b4cd2
PH
1545/* The desc_* routines return primitive portions of array descriptors
1546 (fat pointers). */
14f9c5c9
AS
1547
1548/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1549 level of indirection, if needed. */
1550
d2e4a39e
AS
1551static struct type *
1552desc_base_type (struct type *type)
14f9c5c9
AS
1553{
1554 if (type == NULL)
1555 return NULL;
61ee279c 1556 type = ada_check_typedef (type);
720d1a40
JB
1557 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1558 type = ada_typedef_target_type (type);
1559
1265e4aa
JB
1560 if (type != NULL
1561 && (TYPE_CODE (type) == TYPE_CODE_PTR
1562 || TYPE_CODE (type) == TYPE_CODE_REF))
61ee279c 1563 return ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9
AS
1564 else
1565 return type;
1566}
1567
4c4b4cd2
PH
1568/* True iff TYPE indicates a "thin" array pointer type. */
1569
14f9c5c9 1570static int
d2e4a39e 1571is_thin_pntr (struct type *type)
14f9c5c9 1572{
d2e4a39e 1573 return
14f9c5c9
AS
1574 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1575 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1576}
1577
4c4b4cd2
PH
1578/* The descriptor type for thin pointer type TYPE. */
1579
d2e4a39e
AS
1580static struct type *
1581thin_descriptor_type (struct type *type)
14f9c5c9 1582{
d2e4a39e 1583 struct type *base_type = desc_base_type (type);
5b4ee69b 1584
14f9c5c9
AS
1585 if (base_type == NULL)
1586 return NULL;
1587 if (is_suffix (ada_type_name (base_type), "___XVE"))
1588 return base_type;
d2e4a39e 1589 else
14f9c5c9 1590 {
d2e4a39e 1591 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
5b4ee69b 1592
14f9c5c9 1593 if (alt_type == NULL)
4c4b4cd2 1594 return base_type;
14f9c5c9 1595 else
4c4b4cd2 1596 return alt_type;
14f9c5c9
AS
1597 }
1598}
1599
4c4b4cd2
PH
1600/* A pointer to the array data for thin-pointer value VAL. */
1601
d2e4a39e
AS
1602static struct value *
1603thin_data_pntr (struct value *val)
14f9c5c9 1604{
828292f2 1605 struct type *type = ada_check_typedef (value_type (val));
556bdfd4 1606 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
5b4ee69b 1607
556bdfd4
UW
1608 data_type = lookup_pointer_type (data_type);
1609
14f9c5c9 1610 if (TYPE_CODE (type) == TYPE_CODE_PTR)
556bdfd4 1611 return value_cast (data_type, value_copy (val));
d2e4a39e 1612 else
42ae5230 1613 return value_from_longest (data_type, value_address (val));
14f9c5c9
AS
1614}
1615
4c4b4cd2
PH
1616/* True iff TYPE indicates a "thick" array pointer type. */
1617
14f9c5c9 1618static int
d2e4a39e 1619is_thick_pntr (struct type *type)
14f9c5c9
AS
1620{
1621 type = desc_base_type (type);
1622 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1623 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1624}
1625
4c4b4cd2
PH
1626/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1627 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1628
d2e4a39e
AS
1629static struct type *
1630desc_bounds_type (struct type *type)
14f9c5c9 1631{
d2e4a39e 1632 struct type *r;
14f9c5c9
AS
1633
1634 type = desc_base_type (type);
1635
1636 if (type == NULL)
1637 return NULL;
1638 else if (is_thin_pntr (type))
1639 {
1640 type = thin_descriptor_type (type);
1641 if (type == NULL)
4c4b4cd2 1642 return NULL;
14f9c5c9
AS
1643 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1644 if (r != NULL)
61ee279c 1645 return ada_check_typedef (r);
14f9c5c9
AS
1646 }
1647 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1648 {
1649 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1650 if (r != NULL)
61ee279c 1651 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
14f9c5c9
AS
1652 }
1653 return NULL;
1654}
1655
1656/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1657 one, a pointer to its bounds data. Otherwise NULL. */
1658
d2e4a39e
AS
1659static struct value *
1660desc_bounds (struct value *arr)
14f9c5c9 1661{
df407dfe 1662 struct type *type = ada_check_typedef (value_type (arr));
5b4ee69b 1663
d2e4a39e 1664 if (is_thin_pntr (type))
14f9c5c9 1665 {
d2e4a39e 1666 struct type *bounds_type =
4c4b4cd2 1667 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1668 LONGEST addr;
1669
4cdfadb1 1670 if (bounds_type == NULL)
323e0a4a 1671 error (_("Bad GNAT array descriptor"));
14f9c5c9
AS
1672
1673 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1674 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1675 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1676 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1677 addr = value_as_long (arr);
d2e4a39e 1678 else
42ae5230 1679 addr = value_address (arr);
14f9c5c9 1680
d2e4a39e 1681 return
4c4b4cd2
PH
1682 value_from_longest (lookup_pointer_type (bounds_type),
1683 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1684 }
1685
1686 else if (is_thick_pntr (type))
05e522ef
JB
1687 {
1688 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1689 _("Bad GNAT array descriptor"));
1690 struct type *p_bounds_type = value_type (p_bounds);
1691
1692 if (p_bounds_type
1693 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1694 {
1695 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1696
1697 if (TYPE_STUB (target_type))
1698 p_bounds = value_cast (lookup_pointer_type
1699 (ada_check_typedef (target_type)),
1700 p_bounds);
1701 }
1702 else
1703 error (_("Bad GNAT array descriptor"));
1704
1705 return p_bounds;
1706 }
14f9c5c9
AS
1707 else
1708 return NULL;
1709}
1710
4c4b4cd2
PH
1711/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1712 position of the field containing the address of the bounds data. */
1713
14f9c5c9 1714static int
d2e4a39e 1715fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1716{
1717 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1718}
1719
1720/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1721 size of the field containing the address of the bounds data. */
1722
14f9c5c9 1723static int
d2e4a39e 1724fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1725{
1726 type = desc_base_type (type);
1727
d2e4a39e 1728 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1729 return TYPE_FIELD_BITSIZE (type, 1);
1730 else
61ee279c 1731 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
14f9c5c9
AS
1732}
1733
4c4b4cd2 1734/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
556bdfd4
UW
1735 pointer to one, the type of its array data (a array-with-no-bounds type);
1736 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1737 data. */
4c4b4cd2 1738
d2e4a39e 1739static struct type *
556bdfd4 1740desc_data_target_type (struct type *type)
14f9c5c9
AS
1741{
1742 type = desc_base_type (type);
1743
4c4b4cd2 1744 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1745 if (is_thin_pntr (type))
556bdfd4 1746 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
14f9c5c9 1747 else if (is_thick_pntr (type))
556bdfd4
UW
1748 {
1749 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1750
1751 if (data_type
1752 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
05e522ef 1753 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
556bdfd4
UW
1754 }
1755
1756 return NULL;
14f9c5c9
AS
1757}
1758
1759/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1760 its array data. */
4c4b4cd2 1761
d2e4a39e
AS
1762static struct value *
1763desc_data (struct value *arr)
14f9c5c9 1764{
df407dfe 1765 struct type *type = value_type (arr);
5b4ee69b 1766
14f9c5c9
AS
1767 if (is_thin_pntr (type))
1768 return thin_data_pntr (arr);
1769 else if (is_thick_pntr (type))
d2e4a39e 1770 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
323e0a4a 1771 _("Bad GNAT array descriptor"));
14f9c5c9
AS
1772 else
1773 return NULL;
1774}
1775
1776
1777/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1778 position of the field containing the address of the data. */
1779
14f9c5c9 1780static int
d2e4a39e 1781fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1782{
1783 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1784}
1785
1786/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1787 size of the field containing the address of the data. */
1788
14f9c5c9 1789static int
d2e4a39e 1790fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1791{
1792 type = desc_base_type (type);
1793
1794 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1795 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1796 else
14f9c5c9
AS
1797 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1798}
1799
4c4b4cd2 1800/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1801 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1802 bound, if WHICH is 1. The first bound is I=1. */
1803
d2e4a39e
AS
1804static struct value *
1805desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1806{
d2e4a39e 1807 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
323e0a4a 1808 _("Bad GNAT array descriptor bounds"));
14f9c5c9
AS
1809}
1810
1811/* If BOUNDS is an array-bounds structure type, return the bit position
1812 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1813 bound, if WHICH is 1. The first bound is I=1. */
1814
14f9c5c9 1815static int
d2e4a39e 1816desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1817{
d2e4a39e 1818 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1819}
1820
1821/* If BOUNDS is an array-bounds structure type, return the bit field size
1822 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1823 bound, if WHICH is 1. The first bound is I=1. */
1824
76a01679 1825static int
d2e4a39e 1826desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1827{
1828 type = desc_base_type (type);
1829
d2e4a39e
AS
1830 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1831 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1832 else
1833 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1834}
1835
1836/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1837 Ith bound (numbering from 1). Otherwise, NULL. */
1838
d2e4a39e
AS
1839static struct type *
1840desc_index_type (struct type *type, int i)
14f9c5c9
AS
1841{
1842 type = desc_base_type (type);
1843
1844 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1845 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1846 else
14f9c5c9
AS
1847 return NULL;
1848}
1849
4c4b4cd2
PH
1850/* The number of index positions in the array-bounds type TYPE.
1851 Return 0 if TYPE is NULL. */
1852
14f9c5c9 1853static int
d2e4a39e 1854desc_arity (struct type *type)
14f9c5c9
AS
1855{
1856 type = desc_base_type (type);
1857
1858 if (type != NULL)
1859 return TYPE_NFIELDS (type) / 2;
1860 return 0;
1861}
1862
4c4b4cd2
PH
1863/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1864 an array descriptor type (representing an unconstrained array
1865 type). */
1866
76a01679
JB
1867static int
1868ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1869{
1870 if (type == NULL)
1871 return 0;
61ee279c 1872 type = ada_check_typedef (type);
4c4b4cd2 1873 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1874 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1875}
1876
52ce6436 1877/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
0963b4bd 1878 * to one. */
52ce6436 1879
2c0b251b 1880static int
52ce6436
PH
1881ada_is_array_type (struct type *type)
1882{
1883 while (type != NULL
1884 && (TYPE_CODE (type) == TYPE_CODE_PTR
1885 || TYPE_CODE (type) == TYPE_CODE_REF))
1886 type = TYPE_TARGET_TYPE (type);
1887 return ada_is_direct_array_type (type);
1888}
1889
4c4b4cd2 1890/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1891
14f9c5c9 1892int
4c4b4cd2 1893ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1894{
1895 if (type == NULL)
1896 return 0;
61ee279c 1897 type = ada_check_typedef (type);
14f9c5c9 1898 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2 1899 || (TYPE_CODE (type) == TYPE_CODE_PTR
b0dd7688
JB
1900 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1901 == TYPE_CODE_ARRAY));
14f9c5c9
AS
1902}
1903
4c4b4cd2
PH
1904/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1905
14f9c5c9 1906int
4c4b4cd2 1907ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1908{
556bdfd4 1909 struct type *data_type = desc_data_target_type (type);
14f9c5c9
AS
1910
1911 if (type == NULL)
1912 return 0;
61ee279c 1913 type = ada_check_typedef (type);
556bdfd4
UW
1914 return (data_type != NULL
1915 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1916 && desc_arity (desc_bounds_type (type)) > 0);
14f9c5c9
AS
1917}
1918
1919/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1920 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1921 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1922 is still needed. */
1923
14f9c5c9 1924int
ebf56fd3 1925ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1926{
d2e4a39e 1927 return
14f9c5c9
AS
1928 type != NULL
1929 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1930 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1931 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1932 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1933}
1934
1935
4c4b4cd2 1936/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1937 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1938 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1939 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1940 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1941 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1942 a descriptor. */
d2e4a39e
AS
1943struct type *
1944ada_type_of_array (struct value *arr, int bounds)
14f9c5c9 1945{
ad82864c
JB
1946 if (ada_is_constrained_packed_array_type (value_type (arr)))
1947 return decode_constrained_packed_array_type (value_type (arr));
14f9c5c9 1948
df407dfe
AC
1949 if (!ada_is_array_descriptor_type (value_type (arr)))
1950 return value_type (arr);
d2e4a39e
AS
1951
1952 if (!bounds)
ad82864c
JB
1953 {
1954 struct type *array_type =
1955 ada_check_typedef (desc_data_target_type (value_type (arr)));
1956
1957 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1958 TYPE_FIELD_BITSIZE (array_type, 0) =
1959 decode_packed_array_bitsize (value_type (arr));
1960
1961 return array_type;
1962 }
14f9c5c9
AS
1963 else
1964 {
d2e4a39e 1965 struct type *elt_type;
14f9c5c9 1966 int arity;
d2e4a39e 1967 struct value *descriptor;
14f9c5c9 1968
df407dfe
AC
1969 elt_type = ada_array_element_type (value_type (arr), -1);
1970 arity = ada_array_arity (value_type (arr));
14f9c5c9 1971
d2e4a39e 1972 if (elt_type == NULL || arity == 0)
df407dfe 1973 return ada_check_typedef (value_type (arr));
14f9c5c9
AS
1974
1975 descriptor = desc_bounds (arr);
d2e4a39e 1976 if (value_as_long (descriptor) == 0)
4c4b4cd2 1977 return NULL;
d2e4a39e 1978 while (arity > 0)
4c4b4cd2 1979 {
e9bb382b
UW
1980 struct type *range_type = alloc_type_copy (value_type (arr));
1981 struct type *array_type = alloc_type_copy (value_type (arr));
4c4b4cd2
PH
1982 struct value *low = desc_one_bound (descriptor, arity, 0);
1983 struct value *high = desc_one_bound (descriptor, arity, 1);
4c4b4cd2 1984
5b4ee69b 1985 arity -= 1;
0c9c3474
SA
1986 create_static_range_type (range_type, value_type (low),
1987 longest_to_int (value_as_long (low)),
1988 longest_to_int (value_as_long (high)));
4c4b4cd2 1989 elt_type = create_array_type (array_type, elt_type, range_type);
ad82864c
JB
1990
1991 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
e67ad678
JB
1992 {
1993 /* We need to store the element packed bitsize, as well as
1994 recompute the array size, because it was previously
1995 computed based on the unpacked element size. */
1996 LONGEST lo = value_as_long (low);
1997 LONGEST hi = value_as_long (high);
1998
1999 TYPE_FIELD_BITSIZE (elt_type, 0) =
2000 decode_packed_array_bitsize (value_type (arr));
2001 /* If the array has no element, then the size is already
2002 zero, and does not need to be recomputed. */
2003 if (lo < hi)
2004 {
2005 int array_bitsize =
2006 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2007
2008 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2009 }
2010 }
4c4b4cd2 2011 }
14f9c5c9
AS
2012
2013 return lookup_pointer_type (elt_type);
2014 }
2015}
2016
2017/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
2018 Otherwise, returns either a standard GDB array with bounds set
2019 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2020 GDB array. Returns NULL if ARR is a null fat pointer. */
2021
d2e4a39e
AS
2022struct value *
2023ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 2024{
df407dfe 2025 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2026 {
d2e4a39e 2027 struct type *arrType = ada_type_of_array (arr, 1);
5b4ee69b 2028
14f9c5c9 2029 if (arrType == NULL)
4c4b4cd2 2030 return NULL;
14f9c5c9
AS
2031 return value_cast (arrType, value_copy (desc_data (arr)));
2032 }
ad82864c
JB
2033 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2034 return decode_constrained_packed_array (arr);
14f9c5c9
AS
2035 else
2036 return arr;
2037}
2038
2039/* If ARR does not represent an array, returns ARR unchanged.
2040 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
2041 be ARR itself if it already is in the proper form). */
2042
720d1a40 2043struct value *
d2e4a39e 2044ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 2045{
df407dfe 2046 if (ada_is_array_descriptor_type (value_type (arr)))
14f9c5c9 2047 {
d2e4a39e 2048 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
5b4ee69b 2049
14f9c5c9 2050 if (arrVal == NULL)
323e0a4a 2051 error (_("Bounds unavailable for null array pointer."));
c1b5a1a6 2052 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
14f9c5c9
AS
2053 return value_ind (arrVal);
2054 }
ad82864c
JB
2055 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2056 return decode_constrained_packed_array (arr);
d2e4a39e 2057 else
14f9c5c9
AS
2058 return arr;
2059}
2060
2061/* If TYPE represents a GNAT array type, return it translated to an
2062 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
2063 packing). For other types, is the identity. */
2064
d2e4a39e
AS
2065struct type *
2066ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 2067{
ad82864c
JB
2068 if (ada_is_constrained_packed_array_type (type))
2069 return decode_constrained_packed_array_type (type);
17280b9f
UW
2070
2071 if (ada_is_array_descriptor_type (type))
556bdfd4 2072 return ada_check_typedef (desc_data_target_type (type));
17280b9f
UW
2073
2074 return type;
14f9c5c9
AS
2075}
2076
4c4b4cd2
PH
2077/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2078
ad82864c
JB
2079static int
2080ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
2081{
2082 if (type == NULL)
2083 return 0;
4c4b4cd2 2084 type = desc_base_type (type);
61ee279c 2085 type = ada_check_typedef (type);
d2e4a39e 2086 return
14f9c5c9
AS
2087 ada_type_name (type) != NULL
2088 && strstr (ada_type_name (type), "___XP") != NULL;
2089}
2090
ad82864c
JB
2091/* Non-zero iff TYPE represents a standard GNAT constrained
2092 packed-array type. */
2093
2094int
2095ada_is_constrained_packed_array_type (struct type *type)
2096{
2097 return ada_is_packed_array_type (type)
2098 && !ada_is_array_descriptor_type (type);
2099}
2100
2101/* Non-zero iff TYPE represents an array descriptor for a
2102 unconstrained packed-array type. */
2103
2104static int
2105ada_is_unconstrained_packed_array_type (struct type *type)
2106{
2107 return ada_is_packed_array_type (type)
2108 && ada_is_array_descriptor_type (type);
2109}
2110
2111/* Given that TYPE encodes a packed array type (constrained or unconstrained),
2112 return the size of its elements in bits. */
2113
2114static long
2115decode_packed_array_bitsize (struct type *type)
2116{
0d5cff50
DE
2117 const char *raw_name;
2118 const char *tail;
ad82864c
JB
2119 long bits;
2120
720d1a40
JB
2121 /* Access to arrays implemented as fat pointers are encoded as a typedef
2122 of the fat pointer type. We need the name of the fat pointer type
2123 to do the decoding, so strip the typedef layer. */
2124 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2125 type = ada_typedef_target_type (type);
2126
2127 raw_name = ada_type_name (ada_check_typedef (type));
ad82864c
JB
2128 if (!raw_name)
2129 raw_name = ada_type_name (desc_base_type (type));
2130
2131 if (!raw_name)
2132 return 0;
2133
2134 tail = strstr (raw_name, "___XP");
720d1a40 2135 gdb_assert (tail != NULL);
ad82864c
JB
2136
2137 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2138 {
2139 lim_warning
2140 (_("could not understand bit size information on packed array"));
2141 return 0;
2142 }
2143
2144 return bits;
2145}
2146
14f9c5c9
AS
2147/* Given that TYPE is a standard GDB array type with all bounds filled
2148 in, and that the element size of its ultimate scalar constituents
2149 (that is, either its elements, or, if it is an array of arrays, its
2150 elements' elements, etc.) is *ELT_BITS, return an identical type,
2151 but with the bit sizes of its elements (and those of any
2152 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2 2153 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
4a46959e
JB
2154 in bits.
2155
2156 Note that, for arrays whose index type has an XA encoding where
2157 a bound references a record discriminant, getting that discriminant,
2158 and therefore the actual value of that bound, is not possible
2159 because none of the given parameters gives us access to the record.
2160 This function assumes that it is OK in the context where it is being
2161 used to return an array whose bounds are still dynamic and where
2162 the length is arbitrary. */
4c4b4cd2 2163
d2e4a39e 2164static struct type *
ad82864c 2165constrained_packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 2166{
d2e4a39e
AS
2167 struct type *new_elt_type;
2168 struct type *new_type;
99b1c762
JB
2169 struct type *index_type_desc;
2170 struct type *index_type;
14f9c5c9
AS
2171 LONGEST low_bound, high_bound;
2172
61ee279c 2173 type = ada_check_typedef (type);
14f9c5c9
AS
2174 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2175 return type;
2176
99b1c762
JB
2177 index_type_desc = ada_find_parallel_type (type, "___XA");
2178 if (index_type_desc)
2179 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2180 NULL);
2181 else
2182 index_type = TYPE_INDEX_TYPE (type);
2183
e9bb382b 2184 new_type = alloc_type_copy (type);
ad82864c
JB
2185 new_elt_type =
2186 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2187 elt_bits);
99b1c762 2188 create_array_type (new_type, new_elt_type, index_type);
14f9c5c9
AS
2189 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2190 TYPE_NAME (new_type) = ada_type_name (type);
2191
4a46959e
JB
2192 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2193 && is_dynamic_type (check_typedef (index_type)))
2194 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
14f9c5c9
AS
2195 low_bound = high_bound = 0;
2196 if (high_bound < low_bound)
2197 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 2198 else
14f9c5c9
AS
2199 {
2200 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 2201 TYPE_LENGTH (new_type) =
4c4b4cd2 2202 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
2203 }
2204
876cecd0 2205 TYPE_FIXED_INSTANCE (new_type) = 1;
14f9c5c9
AS
2206 return new_type;
2207}
2208
ad82864c
JB
2209/* The array type encoded by TYPE, where
2210 ada_is_constrained_packed_array_type (TYPE). */
4c4b4cd2 2211
d2e4a39e 2212static struct type *
ad82864c 2213decode_constrained_packed_array_type (struct type *type)
d2e4a39e 2214{
0d5cff50 2215 const char *raw_name = ada_type_name (ada_check_typedef (type));
727e3d2e 2216 char *name;
0d5cff50 2217 const char *tail;
d2e4a39e 2218 struct type *shadow_type;
14f9c5c9 2219 long bits;
14f9c5c9 2220
727e3d2e
JB
2221 if (!raw_name)
2222 raw_name = ada_type_name (desc_base_type (type));
2223
2224 if (!raw_name)
2225 return NULL;
2226
2227 name = (char *) alloca (strlen (raw_name) + 1);
2228 tail = strstr (raw_name, "___XP");
4c4b4cd2
PH
2229 type = desc_base_type (type);
2230
14f9c5c9
AS
2231 memcpy (name, raw_name, tail - raw_name);
2232 name[tail - raw_name] = '\000';
2233
b4ba55a1
JB
2234 shadow_type = ada_find_parallel_type_with_name (type, name);
2235
2236 if (shadow_type == NULL)
14f9c5c9 2237 {
323e0a4a 2238 lim_warning (_("could not find bounds information on packed array"));
14f9c5c9
AS
2239 return NULL;
2240 }
f168693b 2241 shadow_type = check_typedef (shadow_type);
14f9c5c9
AS
2242
2243 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2244 {
0963b4bd
MS
2245 lim_warning (_("could not understand bounds "
2246 "information on packed array"));
14f9c5c9
AS
2247 return NULL;
2248 }
d2e4a39e 2249
ad82864c
JB
2250 bits = decode_packed_array_bitsize (type);
2251 return constrained_packed_array_type (shadow_type, &bits);
14f9c5c9
AS
2252}
2253
ad82864c
JB
2254/* Given that ARR is a struct value *indicating a GNAT constrained packed
2255 array, returns a simple array that denotes that array. Its type is a
14f9c5c9
AS
2256 standard GDB array type except that the BITSIZEs of the array
2257 target types are set to the number of bits in each element, and the
4c4b4cd2 2258 type length is set appropriately. */
14f9c5c9 2259
d2e4a39e 2260static struct value *
ad82864c 2261decode_constrained_packed_array (struct value *arr)
14f9c5c9 2262{
4c4b4cd2 2263 struct type *type;
14f9c5c9 2264
11aa919a
PMR
2265 /* If our value is a pointer, then dereference it. Likewise if
2266 the value is a reference. Make sure that this operation does not
2267 cause the target type to be fixed, as this would indirectly cause
2268 this array to be decoded. The rest of the routine assumes that
2269 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2270 and "value_ind" routines to perform the dereferencing, as opposed
2271 to using "ada_coerce_ref" or "ada_value_ind". */
2272 arr = coerce_ref (arr);
828292f2 2273 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
284614f0 2274 arr = value_ind (arr);
4c4b4cd2 2275
ad82864c 2276 type = decode_constrained_packed_array_type (value_type (arr));
14f9c5c9
AS
2277 if (type == NULL)
2278 {
323e0a4a 2279 error (_("can't unpack array"));
14f9c5c9
AS
2280 return NULL;
2281 }
61ee279c 2282
50810684 2283 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
32c9a795 2284 && ada_is_modular_type (value_type (arr)))
61ee279c
PH
2285 {
2286 /* This is a (right-justified) modular type representing a packed
2287 array with no wrapper. In order to interpret the value through
2288 the (left-justified) packed array type we just built, we must
2289 first left-justify it. */
2290 int bit_size, bit_pos;
2291 ULONGEST mod;
2292
df407dfe 2293 mod = ada_modulus (value_type (arr)) - 1;
61ee279c
PH
2294 bit_size = 0;
2295 while (mod > 0)
2296 {
2297 bit_size += 1;
2298 mod >>= 1;
2299 }
df407dfe 2300 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
61ee279c
PH
2301 arr = ada_value_primitive_packed_val (arr, NULL,
2302 bit_pos / HOST_CHAR_BIT,
2303 bit_pos % HOST_CHAR_BIT,
2304 bit_size,
2305 type);
2306 }
2307
4c4b4cd2 2308 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
2309}
2310
2311
2312/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 2313 given in IND. ARR must be a simple array. */
14f9c5c9 2314
d2e4a39e
AS
2315static struct value *
2316value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2317{
2318 int i;
2319 int bits, elt_off, bit_off;
2320 long elt_total_bit_offset;
d2e4a39e
AS
2321 struct type *elt_type;
2322 struct value *v;
14f9c5c9
AS
2323
2324 bits = 0;
2325 elt_total_bit_offset = 0;
df407dfe 2326 elt_type = ada_check_typedef (value_type (arr));
d2e4a39e 2327 for (i = 0; i < arity; i += 1)
14f9c5c9 2328 {
d2e4a39e 2329 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
2330 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2331 error
0963b4bd
MS
2332 (_("attempt to do packed indexing of "
2333 "something other than a packed array"));
14f9c5c9 2334 else
4c4b4cd2
PH
2335 {
2336 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2337 LONGEST lowerbound, upperbound;
2338 LONGEST idx;
2339
2340 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2341 {
323e0a4a 2342 lim_warning (_("don't know bounds of array"));
4c4b4cd2
PH
2343 lowerbound = upperbound = 0;
2344 }
2345
3cb382c9 2346 idx = pos_atr (ind[i]);
4c4b4cd2 2347 if (idx < lowerbound || idx > upperbound)
0963b4bd
MS
2348 lim_warning (_("packed array index %ld out of bounds"),
2349 (long) idx);
4c4b4cd2
PH
2350 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2351 elt_total_bit_offset += (idx - lowerbound) * bits;
61ee279c 2352 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
4c4b4cd2 2353 }
14f9c5c9
AS
2354 }
2355 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2356 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
2357
2358 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 2359 bits, elt_type);
14f9c5c9
AS
2360 return v;
2361}
2362
4c4b4cd2 2363/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
2364
2365static int
d2e4a39e 2366has_negatives (struct type *type)
14f9c5c9 2367{
d2e4a39e
AS
2368 switch (TYPE_CODE (type))
2369 {
2370 default:
2371 return 0;
2372 case TYPE_CODE_INT:
2373 return !TYPE_UNSIGNED (type);
2374 case TYPE_CODE_RANGE:
2375 return TYPE_LOW_BOUND (type) < 0;
2376 }
14f9c5c9 2377}
d2e4a39e 2378
14f9c5c9
AS
2379
2380/* Create a new value of type TYPE from the contents of OBJ starting
2381 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2382 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
0963b4bd 2383 assigning through the result will set the field fetched from.
4c4b4cd2
PH
2384 VALADDR is ignored unless OBJ is NULL, in which case,
2385 VALADDR+OFFSET must address the start of storage containing the
2386 packed value. The value returned in this case is never an lval.
2387 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 2388
d2e4a39e 2389struct value *
fc1a4b47 2390ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
a2bd3dcd 2391 long offset, int bit_offset, int bit_size,
4c4b4cd2 2392 struct type *type)
14f9c5c9 2393{
d2e4a39e 2394 struct value *v;
4c4b4cd2
PH
2395 int src, /* Index into the source area */
2396 targ, /* Index into the target area */
2397 srcBitsLeft, /* Number of source bits left to move */
2398 nsrc, ntarg, /* Number of source and target bytes */
2399 unusedLS, /* Number of bits in next significant
2400 byte of source that are unused */
2401 accumSize; /* Number of meaningful bits in accum */
2402 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 2403 unsigned char *unpacked;
4c4b4cd2 2404 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
2405 unsigned char sign;
2406 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
2407 /* Transmit bytes from least to most significant; delta is the direction
2408 the indices move. */
50810684 2409 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
14f9c5c9 2410
61ee279c 2411 type = ada_check_typedef (type);
14f9c5c9
AS
2412
2413 if (obj == NULL)
2414 {
2415 v = allocate_value (type);
d2e4a39e 2416 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9 2417 }
9214ee5f 2418 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
14f9c5c9 2419 {
ca34b84f 2420 v = value_at (type, value_address (obj) + offset);
9f1f738a 2421 type = value_type (v);
fc958966
JB
2422 if (TYPE_LENGTH (type) * HOST_CHAR_BIT < bit_size)
2423 {
2424 /* This can happen in the case of an array of dynamic objects,
2425 where the size of each element changes from element to element.
2426 In that case, we're initially given the array stride, but
2427 after resolving the element type, we find that its size is
2428 less than this stride. In that case, adjust bit_size to
2429 match TYPE's length, and recompute LEN accordingly. */
2430 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2431 len = TYPE_LENGTH (type) + (bit_offset + HOST_CHAR_BIT - 1) / 8;
2432 }
d2e4a39e 2433 bytes = (unsigned char *) alloca (len);
ca34b84f 2434 read_memory (value_address (v), bytes, len);
14f9c5c9 2435 }
d2e4a39e 2436 else
14f9c5c9
AS
2437 {
2438 v = allocate_value (type);
0fd88904 2439 bytes = (unsigned char *) value_contents (obj) + offset;
14f9c5c9 2440 }
d2e4a39e
AS
2441
2442 if (obj != NULL)
14f9c5c9 2443 {
53ba8333 2444 long new_offset = offset;
5b4ee69b 2445
74bcbdf3 2446 set_value_component_location (v, obj);
9bbda503
AC
2447 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2448 set_value_bitsize (v, bit_size);
df407dfe 2449 if (value_bitpos (v) >= HOST_CHAR_BIT)
4c4b4cd2 2450 {
53ba8333 2451 ++new_offset;
9bbda503 2452 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
4c4b4cd2 2453 }
53ba8333
JB
2454 set_value_offset (v, new_offset);
2455
2456 /* Also set the parent value. This is needed when trying to
2457 assign a new value (in inferior memory). */
2458 set_value_parent (v, obj);
14f9c5c9
AS
2459 }
2460 else
9bbda503 2461 set_value_bitsize (v, bit_size);
0fd88904 2462 unpacked = (unsigned char *) value_contents (v);
14f9c5c9
AS
2463
2464 srcBitsLeft = bit_size;
2465 nsrc = len;
2466 ntarg = TYPE_LENGTH (type);
2467 sign = 0;
2468 if (bit_size == 0)
2469 {
2470 memset (unpacked, 0, TYPE_LENGTH (type));
2471 return v;
2472 }
50810684 2473 else if (gdbarch_bits_big_endian (get_type_arch (type)))
14f9c5c9 2474 {
d2e4a39e 2475 src = len - 1;
1265e4aa
JB
2476 if (has_negatives (type)
2477 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 2478 sign = ~0;
d2e4a39e
AS
2479
2480 unusedLS =
4c4b4cd2
PH
2481 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2482 % HOST_CHAR_BIT;
14f9c5c9
AS
2483
2484 switch (TYPE_CODE (type))
4c4b4cd2
PH
2485 {
2486 case TYPE_CODE_ARRAY:
2487 case TYPE_CODE_UNION:
2488 case TYPE_CODE_STRUCT:
2489 /* Non-scalar values must be aligned at a byte boundary... */
2490 accumSize =
2491 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2492 /* ... And are placed at the beginning (most-significant) bytes
2493 of the target. */
529cad9c 2494 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
0056e4d5 2495 ntarg = targ + 1;
4c4b4cd2
PH
2496 break;
2497 default:
2498 accumSize = 0;
2499 targ = TYPE_LENGTH (type) - 1;
2500 break;
2501 }
14f9c5c9 2502 }
d2e4a39e 2503 else
14f9c5c9
AS
2504 {
2505 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2506
2507 src = targ = 0;
2508 unusedLS = bit_offset;
2509 accumSize = 0;
2510
d2e4a39e 2511 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 2512 sign = ~0;
14f9c5c9 2513 }
d2e4a39e 2514
14f9c5c9
AS
2515 accum = 0;
2516 while (nsrc > 0)
2517 {
2518 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 2519 part of the value. */
d2e4a39e 2520 unsigned int unusedMSMask =
4c4b4cd2
PH
2521 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2522 1;
2523 /* Sign-extend bits for this byte. */
14f9c5c9 2524 unsigned int signMask = sign & ~unusedMSMask;
5b4ee69b 2525
d2e4a39e 2526 accum |=
4c4b4cd2 2527 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 2528 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 2529 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
2530 {
2531 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2532 accumSize -= HOST_CHAR_BIT;
2533 accum >>= HOST_CHAR_BIT;
2534 ntarg -= 1;
2535 targ += delta;
2536 }
14f9c5c9
AS
2537 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2538 unusedLS = 0;
2539 nsrc -= 1;
2540 src += delta;
2541 }
2542 while (ntarg > 0)
2543 {
2544 accum |= sign << accumSize;
2545 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2546 accumSize -= HOST_CHAR_BIT;
9cd4d857
JB
2547 if (accumSize < 0)
2548 accumSize = 0;
14f9c5c9
AS
2549 accum >>= HOST_CHAR_BIT;
2550 ntarg -= 1;
2551 targ += delta;
2552 }
2553
2478d075
JB
2554 if (is_dynamic_type (value_type (v)))
2555 v = value_from_contents_and_address (value_type (v), value_contents (v),
2556 0);
14f9c5c9
AS
2557 return v;
2558}
d2e4a39e 2559
14f9c5c9
AS
2560/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2561 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 2562 not overlap. */
14f9c5c9 2563static void
fc1a4b47 2564move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
50810684 2565 int src_offset, int n, int bits_big_endian_p)
14f9c5c9
AS
2566{
2567 unsigned int accum, mask;
2568 int accum_bits, chunk_size;
2569
2570 target += targ_offset / HOST_CHAR_BIT;
2571 targ_offset %= HOST_CHAR_BIT;
2572 source += src_offset / HOST_CHAR_BIT;
2573 src_offset %= HOST_CHAR_BIT;
50810684 2574 if (bits_big_endian_p)
14f9c5c9
AS
2575 {
2576 accum = (unsigned char) *source;
2577 source += 1;
2578 accum_bits = HOST_CHAR_BIT - src_offset;
2579
d2e4a39e 2580 while (n > 0)
4c4b4cd2
PH
2581 {
2582 int unused_right;
5b4ee69b 2583
4c4b4cd2
PH
2584 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2585 accum_bits += HOST_CHAR_BIT;
2586 source += 1;
2587 chunk_size = HOST_CHAR_BIT - targ_offset;
2588 if (chunk_size > n)
2589 chunk_size = n;
2590 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2591 mask = ((1 << chunk_size) - 1) << unused_right;
2592 *target =
2593 (*target & ~mask)
2594 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2595 n -= chunk_size;
2596 accum_bits -= chunk_size;
2597 target += 1;
2598 targ_offset = 0;
2599 }
14f9c5c9
AS
2600 }
2601 else
2602 {
2603 accum = (unsigned char) *source >> src_offset;
2604 source += 1;
2605 accum_bits = HOST_CHAR_BIT - src_offset;
2606
d2e4a39e 2607 while (n > 0)
4c4b4cd2
PH
2608 {
2609 accum = accum + ((unsigned char) *source << accum_bits);
2610 accum_bits += HOST_CHAR_BIT;
2611 source += 1;
2612 chunk_size = HOST_CHAR_BIT - targ_offset;
2613 if (chunk_size > n)
2614 chunk_size = n;
2615 mask = ((1 << chunk_size) - 1) << targ_offset;
2616 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2617 n -= chunk_size;
2618 accum_bits -= chunk_size;
2619 accum >>= chunk_size;
2620 target += 1;
2621 targ_offset = 0;
2622 }
14f9c5c9
AS
2623 }
2624}
2625
14f9c5c9
AS
2626/* Store the contents of FROMVAL into the location of TOVAL.
2627 Return a new value with the location of TOVAL and contents of
2628 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2629 floating-point or non-scalar types. */
14f9c5c9 2630
d2e4a39e
AS
2631static struct value *
2632ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2633{
df407dfe
AC
2634 struct type *type = value_type (toval);
2635 int bits = value_bitsize (toval);
14f9c5c9 2636
52ce6436
PH
2637 toval = ada_coerce_ref (toval);
2638 fromval = ada_coerce_ref (fromval);
2639
2640 if (ada_is_direct_array_type (value_type (toval)))
2641 toval = ada_coerce_to_simple_array (toval);
2642 if (ada_is_direct_array_type (value_type (fromval)))
2643 fromval = ada_coerce_to_simple_array (fromval);
2644
88e3b34b 2645 if (!deprecated_value_modifiable (toval))
323e0a4a 2646 error (_("Left operand of assignment is not a modifiable lvalue."));
14f9c5c9 2647
d2e4a39e 2648 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2649 && bits > 0
d2e4a39e 2650 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2651 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2652 {
df407dfe
AC
2653 int len = (value_bitpos (toval)
2654 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
aced2898 2655 int from_size;
948f8e3d 2656 gdb_byte *buffer = alloca (len);
d2e4a39e 2657 struct value *val;
42ae5230 2658 CORE_ADDR to_addr = value_address (toval);
14f9c5c9
AS
2659
2660 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2661 fromval = value_cast (type, fromval);
14f9c5c9 2662
52ce6436 2663 read_memory (to_addr, buffer, len);
aced2898
PH
2664 from_size = value_bitsize (fromval);
2665 if (from_size == 0)
2666 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
50810684 2667 if (gdbarch_bits_big_endian (get_type_arch (type)))
df407dfe 2668 move_bits (buffer, value_bitpos (toval),
50810684 2669 value_contents (fromval), from_size - bits, bits, 1);
14f9c5c9 2670 else
50810684
UW
2671 move_bits (buffer, value_bitpos (toval),
2672 value_contents (fromval), 0, bits, 0);
972daa01 2673 write_memory_with_notification (to_addr, buffer, len);
8cebebb9 2674
14f9c5c9 2675 val = value_copy (toval);
0fd88904 2676 memcpy (value_contents_raw (val), value_contents (fromval),
4c4b4cd2 2677 TYPE_LENGTH (type));
04624583 2678 deprecated_set_value_type (val, type);
d2e4a39e 2679
14f9c5c9
AS
2680 return val;
2681 }
2682
2683 return value_assign (toval, fromval);
2684}
2685
2686
7c512744
JB
2687/* Given that COMPONENT is a memory lvalue that is part of the lvalue
2688 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2689 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2690 COMPONENT, and not the inferior's memory. The current contents
2691 of COMPONENT are ignored.
2692
2693 Although not part of the initial design, this function also works
2694 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2695 had a null address, and COMPONENT had an address which is equal to
2696 its offset inside CONTAINER. */
2697
52ce6436
PH
2698static void
2699value_assign_to_component (struct value *container, struct value *component,
2700 struct value *val)
2701{
2702 LONGEST offset_in_container =
42ae5230 2703 (LONGEST) (value_address (component) - value_address (container));
7c512744 2704 int bit_offset_in_container =
52ce6436
PH
2705 value_bitpos (component) - value_bitpos (container);
2706 int bits;
7c512744 2707
52ce6436
PH
2708 val = value_cast (value_type (component), val);
2709
2710 if (value_bitsize (component) == 0)
2711 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2712 else
2713 bits = value_bitsize (component);
2714
50810684 2715 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
7c512744 2716 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436
PH
2717 value_bitpos (container) + bit_offset_in_container,
2718 value_contents (val),
2719 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
50810684 2720 bits, 1);
52ce6436 2721 else
7c512744 2722 move_bits (value_contents_writeable (container) + offset_in_container,
52ce6436 2723 value_bitpos (container) + bit_offset_in_container,
50810684 2724 value_contents (val), 0, bits, 0);
7c512744
JB
2725}
2726
4c4b4cd2
PH
2727/* The value of the element of array ARR at the ARITY indices given in IND.
2728 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2729 thereto. */
2730
d2e4a39e
AS
2731struct value *
2732ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2733{
2734 int k;
d2e4a39e
AS
2735 struct value *elt;
2736 struct type *elt_type;
14f9c5c9
AS
2737
2738 elt = ada_coerce_to_simple_array (arr);
2739
df407dfe 2740 elt_type = ada_check_typedef (value_type (elt));
d2e4a39e 2741 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2742 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2743 return value_subscript_packed (elt, arity, ind);
2744
2745 for (k = 0; k < arity; k += 1)
2746 {
2747 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
323e0a4a 2748 error (_("too many subscripts (%d expected)"), k);
2497b498 2749 elt = value_subscript (elt, pos_atr (ind[k]));
14f9c5c9
AS
2750 }
2751 return elt;
2752}
2753
deede10c
JB
2754/* Assuming ARR is a pointer to a GDB array, the value of the element
2755 of *ARR at the ARITY indices given in IND.
2756 Does not read the entire array into memory. */
14f9c5c9 2757
2c0b251b 2758static struct value *
deede10c 2759ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2760{
2761 int k;
deede10c
JB
2762 struct type *type
2763 = check_typedef (value_enclosing_type (ada_value_ind (arr)));
14f9c5c9
AS
2764
2765 for (k = 0; k < arity; k += 1)
2766 {
2767 LONGEST lwb, upb;
aa715135 2768 struct value *lwb_value;
14f9c5c9
AS
2769
2770 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
323e0a4a 2771 error (_("too many subscripts (%d expected)"), k);
d2e4a39e 2772 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2773 value_copy (arr));
14f9c5c9 2774 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
aa715135
JG
2775 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2776 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
14f9c5c9
AS
2777 type = TYPE_TARGET_TYPE (type);
2778 }
2779
2780 return value_ind (arr);
2781}
2782
0b5d8877 2783/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
aa715135
JG
2784 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2785 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2786 this array is LOW, as per Ada rules. */
0b5d8877 2787static struct value *
f5938064
JG
2788ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2789 int low, int high)
0b5d8877 2790{
b0dd7688 2791 struct type *type0 = ada_check_typedef (type);
aa715135 2792 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
0c9c3474 2793 struct type *index_type
aa715135 2794 = create_static_range_type (NULL, base_index_type, low, high);
6c038f32 2795 struct type *slice_type =
b0dd7688 2796 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
aa715135
JG
2797 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2798 LONGEST base_low_pos, low_pos;
2799 CORE_ADDR base;
2800
2801 if (!discrete_position (base_index_type, low, &low_pos)
2802 || !discrete_position (base_index_type, base_low, &base_low_pos))
2803 {
2804 warning (_("unable to get positions in slice, use bounds instead"));
2805 low_pos = low;
2806 base_low_pos = base_low;
2807 }
5b4ee69b 2808
aa715135
JG
2809 base = value_as_address (array_ptr)
2810 + ((low_pos - base_low_pos)
2811 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
f5938064 2812 return value_at_lazy (slice_type, base);
0b5d8877
PH
2813}
2814
2815
2816static struct value *
2817ada_value_slice (struct value *array, int low, int high)
2818{
b0dd7688 2819 struct type *type = ada_check_typedef (value_type (array));
aa715135 2820 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
0c9c3474
SA
2821 struct type *index_type
2822 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
6c038f32 2823 struct type *slice_type =
0b5d8877 2824 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
aa715135 2825 LONGEST low_pos, high_pos;
5b4ee69b 2826
aa715135
JG
2827 if (!discrete_position (base_index_type, low, &low_pos)
2828 || !discrete_position (base_index_type, high, &high_pos))
2829 {
2830 warning (_("unable to get positions in slice, use bounds instead"));
2831 low_pos = low;
2832 high_pos = high;
2833 }
2834
2835 return value_cast (slice_type,
2836 value_slice (array, low, high_pos - low_pos + 1));
0b5d8877
PH
2837}
2838
14f9c5c9
AS
2839/* If type is a record type in the form of a standard GNAT array
2840 descriptor, returns the number of dimensions for type. If arr is a
2841 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2842 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2843
2844int
d2e4a39e 2845ada_array_arity (struct type *type)
14f9c5c9
AS
2846{
2847 int arity;
2848
2849 if (type == NULL)
2850 return 0;
2851
2852 type = desc_base_type (type);
2853
2854 arity = 0;
d2e4a39e 2855 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2856 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2857 else
2858 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2859 {
4c4b4cd2 2860 arity += 1;
61ee279c 2861 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2862 }
d2e4a39e 2863
14f9c5c9
AS
2864 return arity;
2865}
2866
2867/* If TYPE is a record type in the form of a standard GNAT array
2868 descriptor or a simple array type, returns the element type for
2869 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2870 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2871
d2e4a39e
AS
2872struct type *
2873ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2874{
2875 type = desc_base_type (type);
2876
d2e4a39e 2877 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2878 {
2879 int k;
d2e4a39e 2880 struct type *p_array_type;
14f9c5c9 2881
556bdfd4 2882 p_array_type = desc_data_target_type (type);
14f9c5c9
AS
2883
2884 k = ada_array_arity (type);
2885 if (k == 0)
4c4b4cd2 2886 return NULL;
d2e4a39e 2887
4c4b4cd2 2888 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2889 if (nindices >= 0 && k > nindices)
4c4b4cd2 2890 k = nindices;
d2e4a39e 2891 while (k > 0 && p_array_type != NULL)
4c4b4cd2 2892 {
61ee279c 2893 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
4c4b4cd2
PH
2894 k -= 1;
2895 }
14f9c5c9
AS
2896 return p_array_type;
2897 }
2898 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2899 {
2900 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2901 {
2902 type = TYPE_TARGET_TYPE (type);
2903 nindices -= 1;
2904 }
14f9c5c9
AS
2905 return type;
2906 }
2907
2908 return NULL;
2909}
2910
4c4b4cd2 2911/* The type of nth index in arrays of given type (n numbering from 1).
dd19d49e
UW
2912 Does not examine memory. Throws an error if N is invalid or TYPE
2913 is not an array type. NAME is the name of the Ada attribute being
2914 evaluated ('range, 'first, 'last, or 'length); it is used in building
2915 the error message. */
14f9c5c9 2916
1eea4ebd
UW
2917static struct type *
2918ada_index_type (struct type *type, int n, const char *name)
14f9c5c9 2919{
4c4b4cd2
PH
2920 struct type *result_type;
2921
14f9c5c9
AS
2922 type = desc_base_type (type);
2923
1eea4ebd
UW
2924 if (n < 0 || n > ada_array_arity (type))
2925 error (_("invalid dimension number to '%s"), name);
14f9c5c9 2926
4c4b4cd2 2927 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2928 {
2929 int i;
2930
2931 for (i = 1; i < n; i += 1)
4c4b4cd2 2932 type = TYPE_TARGET_TYPE (type);
262452ec 2933 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
4c4b4cd2
PH
2934 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2935 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679 2936 perhaps stabsread.c would make more sense. */
1eea4ebd
UW
2937 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2938 result_type = NULL;
14f9c5c9 2939 }
d2e4a39e 2940 else
1eea4ebd
UW
2941 {
2942 result_type = desc_index_type (desc_bounds_type (type), n);
2943 if (result_type == NULL)
2944 error (_("attempt to take bound of something that is not an array"));
2945 }
2946
2947 return result_type;
14f9c5c9
AS
2948}
2949
2950/* Given that arr is an array type, returns the lower bound of the
2951 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2 2952 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1eea4ebd
UW
2953 array-descriptor type. It works for other arrays with bounds supplied
2954 by run-time quantities other than discriminants. */
14f9c5c9 2955
abb68b3e 2956static LONGEST
fb5e3d5c 2957ada_array_bound_from_type (struct type *arr_type, int n, int which)
14f9c5c9 2958{
8a48ac95 2959 struct type *type, *index_type_desc, *index_type;
1ce677a4 2960 int i;
262452ec
JK
2961
2962 gdb_assert (which == 0 || which == 1);
14f9c5c9 2963
ad82864c
JB
2964 if (ada_is_constrained_packed_array_type (arr_type))
2965 arr_type = decode_constrained_packed_array_type (arr_type);
14f9c5c9 2966
4c4b4cd2 2967 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
1eea4ebd 2968 return (LONGEST) - which;
14f9c5c9
AS
2969
2970 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2971 type = TYPE_TARGET_TYPE (arr_type);
2972 else
2973 type = arr_type;
2974
bafffb51
JB
2975 if (TYPE_FIXED_INSTANCE (type))
2976 {
2977 /* The array has already been fixed, so we do not need to
2978 check the parallel ___XA type again. That encoding has
2979 already been applied, so ignore it now. */
2980 index_type_desc = NULL;
2981 }
2982 else
2983 {
2984 index_type_desc = ada_find_parallel_type (type, "___XA");
2985 ada_fixup_array_indexes_type (index_type_desc);
2986 }
2987
262452ec 2988 if (index_type_desc != NULL)
28c85d6c
JB
2989 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2990 NULL);
262452ec 2991 else
8a48ac95
JB
2992 {
2993 struct type *elt_type = check_typedef (type);
2994
2995 for (i = 1; i < n; i++)
2996 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2997
2998 index_type = TYPE_INDEX_TYPE (elt_type);
2999 }
262452ec 3000
43bbcdc2
PH
3001 return
3002 (LONGEST) (which == 0
3003 ? ada_discrete_type_low_bound (index_type)
3004 : ada_discrete_type_high_bound (index_type));
14f9c5c9
AS
3005}
3006
3007/* Given that arr is an array value, returns the lower bound of the
abb68b3e
JB
3008 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3009 WHICH is 1. This routine will also work for arrays with bounds
4c4b4cd2 3010 supplied by run-time quantities other than discriminants. */
14f9c5c9 3011
1eea4ebd 3012static LONGEST
4dc81987 3013ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 3014{
eb479039
JB
3015 struct type *arr_type;
3016
3017 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3018 arr = value_ind (arr);
3019 arr_type = value_enclosing_type (arr);
14f9c5c9 3020
ad82864c
JB
3021 if (ada_is_constrained_packed_array_type (arr_type))
3022 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
4c4b4cd2 3023 else if (ada_is_simple_array_type (arr_type))
1eea4ebd 3024 return ada_array_bound_from_type (arr_type, n, which);
14f9c5c9 3025 else
1eea4ebd 3026 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
14f9c5c9
AS
3027}
3028
3029/* Given that arr is an array value, returns the length of the
3030 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
3031 supplied by run-time quantities other than discriminants.
3032 Does not work for arrays indexed by enumeration types with representation
3033 clauses at the moment. */
14f9c5c9 3034
1eea4ebd 3035static LONGEST
d2e4a39e 3036ada_array_length (struct value *arr, int n)
14f9c5c9 3037{
aa715135
JG
3038 struct type *arr_type, *index_type;
3039 int low, high;
eb479039
JB
3040
3041 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3042 arr = value_ind (arr);
3043 arr_type = value_enclosing_type (arr);
14f9c5c9 3044
ad82864c
JB
3045 if (ada_is_constrained_packed_array_type (arr_type))
3046 return ada_array_length (decode_constrained_packed_array (arr), n);
14f9c5c9 3047
4c4b4cd2 3048 if (ada_is_simple_array_type (arr_type))
aa715135
JG
3049 {
3050 low = ada_array_bound_from_type (arr_type, n, 0);
3051 high = ada_array_bound_from_type (arr_type, n, 1);
3052 }
14f9c5c9 3053 else
aa715135
JG
3054 {
3055 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3056 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3057 }
3058
f168693b 3059 arr_type = check_typedef (arr_type);
aa715135
JG
3060 index_type = TYPE_INDEX_TYPE (arr_type);
3061 if (index_type != NULL)
3062 {
3063 struct type *base_type;
3064 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3065 base_type = TYPE_TARGET_TYPE (index_type);
3066 else
3067 base_type = index_type;
3068
3069 low = pos_atr (value_from_longest (base_type, low));
3070 high = pos_atr (value_from_longest (base_type, high));
3071 }
3072 return high - low + 1;
4c4b4cd2
PH
3073}
3074
3075/* An empty array whose type is that of ARR_TYPE (an array type),
3076 with bounds LOW to LOW-1. */
3077
3078static struct value *
3079empty_array (struct type *arr_type, int low)
3080{
b0dd7688 3081 struct type *arr_type0 = ada_check_typedef (arr_type);
0c9c3474
SA
3082 struct type *index_type
3083 = create_static_range_type
3084 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
b0dd7688 3085 struct type *elt_type = ada_array_element_type (arr_type0, 1);
5b4ee69b 3086
0b5d8877 3087 return allocate_value (create_array_type (NULL, elt_type, index_type));
14f9c5c9 3088}
14f9c5c9 3089\f
d2e4a39e 3090
4c4b4cd2 3091 /* Name resolution */
14f9c5c9 3092
4c4b4cd2
PH
3093/* The "decoded" name for the user-definable Ada operator corresponding
3094 to OP. */
14f9c5c9 3095
d2e4a39e 3096static const char *
4c4b4cd2 3097ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
3098{
3099 int i;
3100
4c4b4cd2 3101 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
3102 {
3103 if (ada_opname_table[i].op == op)
4c4b4cd2 3104 return ada_opname_table[i].decoded;
14f9c5c9 3105 }
323e0a4a 3106 error (_("Could not find operator name for opcode"));
14f9c5c9
AS
3107}
3108
3109
4c4b4cd2
PH
3110/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3111 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3112 undefined namespace) and converts operators that are
3113 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
3114 non-null, it provides a preferred result type [at the moment, only
3115 type void has any effect---causing procedures to be preferred over
3116 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 3117 return type is preferred. May change (expand) *EXP. */
14f9c5c9 3118
4c4b4cd2
PH
3119static void
3120resolve (struct expression **expp, int void_context_p)
14f9c5c9 3121{
30b15541
UW
3122 struct type *context_type = NULL;
3123 int pc = 0;
3124
3125 if (void_context_p)
3126 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3127
3128 resolve_subexp (expp, &pc, 1, context_type);
14f9c5c9
AS
3129}
3130
4c4b4cd2
PH
3131/* Resolve the operator of the subexpression beginning at
3132 position *POS of *EXPP. "Resolving" consists of replacing
3133 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3134 with their resolutions, replacing built-in operators with
3135 function calls to user-defined operators, where appropriate, and,
3136 when DEPROCEDURE_P is non-zero, converting function-valued variables
3137 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3138 are as in ada_resolve, above. */
14f9c5c9 3139
d2e4a39e 3140static struct value *
4c4b4cd2 3141resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 3142 struct type *context_type)
14f9c5c9
AS
3143{
3144 int pc = *pos;
3145 int i;
4c4b4cd2 3146 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 3147 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
3148 struct value **argvec; /* Vector of operand types (alloca'ed). */
3149 int nargs; /* Number of operands. */
52ce6436 3150 int oplen;
14f9c5c9
AS
3151
3152 argvec = NULL;
3153 nargs = 0;
3154 exp = *expp;
3155
52ce6436
PH
3156 /* Pass one: resolve operands, saving their types and updating *pos,
3157 if needed. */
14f9c5c9
AS
3158 switch (op)
3159 {
4c4b4cd2
PH
3160 case OP_FUNCALL:
3161 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
3162 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3163 *pos += 7;
4c4b4cd2
PH
3164 else
3165 {
3166 *pos += 3;
3167 resolve_subexp (expp, pos, 0, NULL);
3168 }
3169 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
3170 break;
3171
14f9c5c9 3172 case UNOP_ADDR:
4c4b4cd2
PH
3173 *pos += 1;
3174 resolve_subexp (expp, pos, 0, NULL);
3175 break;
3176
52ce6436
PH
3177 case UNOP_QUAL:
3178 *pos += 3;
17466c1a 3179 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
4c4b4cd2
PH
3180 break;
3181
52ce6436 3182 case OP_ATR_MODULUS:
4c4b4cd2
PH
3183 case OP_ATR_SIZE:
3184 case OP_ATR_TAG:
4c4b4cd2
PH
3185 case OP_ATR_FIRST:
3186 case OP_ATR_LAST:
3187 case OP_ATR_LENGTH:
3188 case OP_ATR_POS:
3189 case OP_ATR_VAL:
4c4b4cd2
PH
3190 case OP_ATR_MIN:
3191 case OP_ATR_MAX:
52ce6436
PH
3192 case TERNOP_IN_RANGE:
3193 case BINOP_IN_BOUNDS:
3194 case UNOP_IN_RANGE:
3195 case OP_AGGREGATE:
3196 case OP_OTHERS:
3197 case OP_CHOICES:
3198 case OP_POSITIONAL:
3199 case OP_DISCRETE_RANGE:
3200 case OP_NAME:
3201 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3202 *pos += oplen;
14f9c5c9
AS
3203 break;
3204
3205 case BINOP_ASSIGN:
3206 {
4c4b4cd2
PH
3207 struct value *arg1;
3208
3209 *pos += 1;
3210 arg1 = resolve_subexp (expp, pos, 0, NULL);
3211 if (arg1 == NULL)
3212 resolve_subexp (expp, pos, 1, NULL);
3213 else
df407dfe 3214 resolve_subexp (expp, pos, 1, value_type (arg1));
4c4b4cd2 3215 break;
14f9c5c9
AS
3216 }
3217
4c4b4cd2 3218 case UNOP_CAST:
4c4b4cd2
PH
3219 *pos += 3;
3220 nargs = 1;
3221 break;
14f9c5c9 3222
4c4b4cd2
PH
3223 case BINOP_ADD:
3224 case BINOP_SUB:
3225 case BINOP_MUL:
3226 case BINOP_DIV:
3227 case BINOP_REM:
3228 case BINOP_MOD:
3229 case BINOP_EXP:
3230 case BINOP_CONCAT:
3231 case BINOP_LOGICAL_AND:
3232 case BINOP_LOGICAL_OR:
3233 case BINOP_BITWISE_AND:
3234 case BINOP_BITWISE_IOR:
3235 case BINOP_BITWISE_XOR:
14f9c5c9 3236
4c4b4cd2
PH
3237 case BINOP_EQUAL:
3238 case BINOP_NOTEQUAL:
3239 case BINOP_LESS:
3240 case BINOP_GTR:
3241 case BINOP_LEQ:
3242 case BINOP_GEQ:
14f9c5c9 3243
4c4b4cd2
PH
3244 case BINOP_REPEAT:
3245 case BINOP_SUBSCRIPT:
3246 case BINOP_COMMA:
40c8aaa9
JB
3247 *pos += 1;
3248 nargs = 2;
3249 break;
14f9c5c9 3250
4c4b4cd2
PH
3251 case UNOP_NEG:
3252 case UNOP_PLUS:
3253 case UNOP_LOGICAL_NOT:
3254 case UNOP_ABS:
3255 case UNOP_IND:
3256 *pos += 1;
3257 nargs = 1;
3258 break;
14f9c5c9 3259
4c4b4cd2
PH
3260 case OP_LONG:
3261 case OP_DOUBLE:
3262 case OP_VAR_VALUE:
3263 *pos += 4;
3264 break;
14f9c5c9 3265
4c4b4cd2
PH
3266 case OP_TYPE:
3267 case OP_BOOL:
3268 case OP_LAST:
4c4b4cd2
PH
3269 case OP_INTERNALVAR:
3270 *pos += 3;
3271 break;
14f9c5c9 3272
4c4b4cd2
PH
3273 case UNOP_MEMVAL:
3274 *pos += 3;
3275 nargs = 1;
3276 break;
3277
67f3407f
DJ
3278 case OP_REGISTER:
3279 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3280 break;
3281
4c4b4cd2
PH
3282 case STRUCTOP_STRUCT:
3283 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3284 nargs = 1;
3285 break;
3286
4c4b4cd2 3287 case TERNOP_SLICE:
4c4b4cd2
PH
3288 *pos += 1;
3289 nargs = 3;
3290 break;
3291
52ce6436 3292 case OP_STRING:
14f9c5c9 3293 break;
4c4b4cd2
PH
3294
3295 default:
323e0a4a 3296 error (_("Unexpected operator during name resolution"));
14f9c5c9
AS
3297 }
3298
76a01679 3299 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
3300 for (i = 0; i < nargs; i += 1)
3301 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3302 argvec[i] = NULL;
3303 exp = *expp;
3304
3305 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
3306 switch (op)
3307 {
3308 default:
3309 break;
3310
14f9c5c9 3311 case OP_VAR_VALUE:
4c4b4cd2 3312 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679 3313 {
d12307c1 3314 struct block_symbol *candidates;
76a01679
JB
3315 int n_candidates;
3316
3317 n_candidates =
3318 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3319 (exp->elts[pc + 2].symbol),
3320 exp->elts[pc + 1].block, VAR_DOMAIN,
4eeaa230 3321 &candidates);
76a01679
JB
3322
3323 if (n_candidates > 1)
3324 {
3325 /* Types tend to get re-introduced locally, so if there
3326 are any local symbols that are not types, first filter
3327 out all types. */
3328 int j;
3329 for (j = 0; j < n_candidates; j += 1)
d12307c1 3330 switch (SYMBOL_CLASS (candidates[j].symbol))
76a01679
JB
3331 {
3332 case LOC_REGISTER:
3333 case LOC_ARG:
3334 case LOC_REF_ARG:
76a01679
JB
3335 case LOC_REGPARM_ADDR:
3336 case LOC_LOCAL:
76a01679 3337 case LOC_COMPUTED:
76a01679
JB
3338 goto FoundNonType;
3339 default:
3340 break;
3341 }
3342 FoundNonType:
3343 if (j < n_candidates)
3344 {
3345 j = 0;
3346 while (j < n_candidates)
3347 {
d12307c1 3348 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
76a01679
JB
3349 {
3350 candidates[j] = candidates[n_candidates - 1];
3351 n_candidates -= 1;
3352 }
3353 else
3354 j += 1;
3355 }
3356 }
3357 }
3358
3359 if (n_candidates == 0)
323e0a4a 3360 error (_("No definition found for %s"),
76a01679
JB
3361 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3362 else if (n_candidates == 1)
3363 i = 0;
3364 else if (deprocedure_p
3365 && !is_nonfunction (candidates, n_candidates))
3366 {
06d5cf63
JB
3367 i = ada_resolve_function
3368 (candidates, n_candidates, NULL, 0,
3369 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3370 context_type);
76a01679 3371 if (i < 0)
323e0a4a 3372 error (_("Could not find a match for %s"),
76a01679
JB
3373 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3374 }
3375 else
3376 {
323e0a4a 3377 printf_filtered (_("Multiple matches for %s\n"),
76a01679
JB
3378 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3379 user_select_syms (candidates, n_candidates, 1);
3380 i = 0;
3381 }
3382
3383 exp->elts[pc + 1].block = candidates[i].block;
d12307c1 3384 exp->elts[pc + 2].symbol = candidates[i].symbol;
1265e4aa
JB
3385 if (innermost_block == NULL
3386 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
3387 innermost_block = candidates[i].block;
3388 }
3389
3390 if (deprocedure_p
3391 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3392 == TYPE_CODE_FUNC))
3393 {
3394 replace_operator_with_call (expp, pc, 0, 0,
3395 exp->elts[pc + 2].symbol,
3396 exp->elts[pc + 1].block);
3397 exp = *expp;
3398 }
14f9c5c9
AS
3399 break;
3400
3401 case OP_FUNCALL:
3402 {
4c4b4cd2 3403 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 3404 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2 3405 {
d12307c1 3406 struct block_symbol *candidates;
4c4b4cd2
PH
3407 int n_candidates;
3408
3409 n_candidates =
76a01679
JB
3410 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3411 (exp->elts[pc + 5].symbol),
3412 exp->elts[pc + 4].block, VAR_DOMAIN,
4eeaa230 3413 &candidates);
4c4b4cd2
PH
3414 if (n_candidates == 1)
3415 i = 0;
3416 else
3417 {
06d5cf63
JB
3418 i = ada_resolve_function
3419 (candidates, n_candidates,
3420 argvec, nargs,
3421 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3422 context_type);
4c4b4cd2 3423 if (i < 0)
323e0a4a 3424 error (_("Could not find a match for %s"),
4c4b4cd2
PH
3425 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3426 }
3427
3428 exp->elts[pc + 4].block = candidates[i].block;
d12307c1 3429 exp->elts[pc + 5].symbol = candidates[i].symbol;
1265e4aa
JB
3430 if (innermost_block == NULL
3431 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
3432 innermost_block = candidates[i].block;
3433 }
14f9c5c9
AS
3434 }
3435 break;
3436 case BINOP_ADD:
3437 case BINOP_SUB:
3438 case BINOP_MUL:
3439 case BINOP_DIV:
3440 case BINOP_REM:
3441 case BINOP_MOD:
3442 case BINOP_CONCAT:
3443 case BINOP_BITWISE_AND:
3444 case BINOP_BITWISE_IOR:
3445 case BINOP_BITWISE_XOR:
3446 case BINOP_EQUAL:
3447 case BINOP_NOTEQUAL:
3448 case BINOP_LESS:
3449 case BINOP_GTR:
3450 case BINOP_LEQ:
3451 case BINOP_GEQ:
3452 case BINOP_EXP:
3453 case UNOP_NEG:
3454 case UNOP_PLUS:
3455 case UNOP_LOGICAL_NOT:
3456 case UNOP_ABS:
3457 if (possible_user_operator_p (op, argvec))
4c4b4cd2 3458 {
d12307c1 3459 struct block_symbol *candidates;
4c4b4cd2
PH
3460 int n_candidates;
3461
3462 n_candidates =
3463 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3464 (struct block *) NULL, VAR_DOMAIN,
4eeaa230 3465 &candidates);
4c4b4cd2 3466 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 3467 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
3468 if (i < 0)
3469 break;
3470
d12307c1
PMR
3471 replace_operator_with_call (expp, pc, nargs, 1,
3472 candidates[i].symbol,
3473 candidates[i].block);
4c4b4cd2
PH
3474 exp = *expp;
3475 }
14f9c5c9 3476 break;
4c4b4cd2
PH
3477
3478 case OP_TYPE:
b3dbf008 3479 case OP_REGISTER:
4c4b4cd2 3480 return NULL;
14f9c5c9
AS
3481 }
3482
3483 *pos = pc;
3484 return evaluate_subexp_type (exp, pos);
3485}
3486
3487/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2 3488 MAY_DEREF is non-zero, the formal may be a pointer and the actual
5b3d5b7d 3489 a non-pointer. */
14f9c5c9 3490/* The term "match" here is rather loose. The match is heuristic and
5b3d5b7d 3491 liberal. */
14f9c5c9
AS
3492
3493static int
4dc81987 3494ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9 3495{
61ee279c
PH
3496 ftype = ada_check_typedef (ftype);
3497 atype = ada_check_typedef (atype);
14f9c5c9
AS
3498
3499 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3500 ftype = TYPE_TARGET_TYPE (ftype);
3501 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3502 atype = TYPE_TARGET_TYPE (atype);
3503
d2e4a39e 3504 switch (TYPE_CODE (ftype))
14f9c5c9
AS
3505 {
3506 default:
5b3d5b7d 3507 return TYPE_CODE (ftype) == TYPE_CODE (atype);
14f9c5c9
AS
3508 case TYPE_CODE_PTR:
3509 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
3510 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3511 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 3512 else
1265e4aa
JB
3513 return (may_deref
3514 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
3515 case TYPE_CODE_INT:
3516 case TYPE_CODE_ENUM:
3517 case TYPE_CODE_RANGE:
3518 switch (TYPE_CODE (atype))
4c4b4cd2
PH
3519 {
3520 case TYPE_CODE_INT:
3521 case TYPE_CODE_ENUM:
3522 case TYPE_CODE_RANGE:
3523 return 1;
3524 default:
3525 return 0;
3526 }
14f9c5c9
AS
3527
3528 case TYPE_CODE_ARRAY:
d2e4a39e 3529 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 3530 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3531
3532 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
3533 if (ada_is_array_descriptor_type (ftype))
3534 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3535 || ada_is_array_descriptor_type (atype));
14f9c5c9 3536 else
4c4b4cd2
PH
3537 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3538 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
3539
3540 case TYPE_CODE_UNION:
3541 case TYPE_CODE_FLT:
3542 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3543 }
3544}
3545
3546/* Return non-zero if the formals of FUNC "sufficiently match" the
3547 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3548 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 3549 argument function. */
14f9c5c9
AS
3550
3551static int
d2e4a39e 3552ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
3553{
3554 int i;
d2e4a39e 3555 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 3556
1265e4aa
JB
3557 if (SYMBOL_CLASS (func) == LOC_CONST
3558 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
3559 return (n_actuals == 0);
3560 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3561 return 0;
3562
3563 if (TYPE_NFIELDS (func_type) != n_actuals)
3564 return 0;
3565
3566 for (i = 0; i < n_actuals; i += 1)
3567 {
4c4b4cd2 3568 if (actuals[i] == NULL)
76a01679
JB
3569 return 0;
3570 else
3571 {
5b4ee69b
MS
3572 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3573 i));
df407dfe 3574 struct type *atype = ada_check_typedef (value_type (actuals[i]));
4c4b4cd2 3575
76a01679
JB
3576 if (!ada_type_match (ftype, atype, 1))
3577 return 0;
3578 }
14f9c5c9
AS
3579 }
3580 return 1;
3581}
3582
3583/* False iff function type FUNC_TYPE definitely does not produce a value
3584 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3585 FUNC_TYPE is not a valid function type with a non-null return type
3586 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3587
3588static int
d2e4a39e 3589return_match (struct type *func_type, struct type *context_type)
14f9c5c9 3590{
d2e4a39e 3591 struct type *return_type;
14f9c5c9
AS
3592
3593 if (func_type == NULL)
3594 return 1;
3595
4c4b4cd2 3596 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
18af8284 3597 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
4c4b4cd2 3598 else
18af8284 3599 return_type = get_base_type (func_type);
14f9c5c9
AS
3600 if (return_type == NULL)
3601 return 1;
3602
18af8284 3603 context_type = get_base_type (context_type);
14f9c5c9
AS
3604
3605 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3606 return context_type == NULL || return_type == context_type;
3607 else if (context_type == NULL)
3608 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3609 else
3610 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3611}
3612
3613
4c4b4cd2 3614/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 3615 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
3616 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3617 that returns that type, then eliminate matches that don't. If
3618 CONTEXT_TYPE is void and there is at least one match that does not
3619 return void, eliminate all matches that do.
3620
14f9c5c9
AS
3621 Asks the user if there is more than one match remaining. Returns -1
3622 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
3623 solely for messages. May re-arrange and modify SYMS in
3624 the process; the index returned is for the modified vector. */
14f9c5c9 3625
4c4b4cd2 3626static int
d12307c1 3627ada_resolve_function (struct block_symbol syms[],
4c4b4cd2
PH
3628 int nsyms, struct value **args, int nargs,
3629 const char *name, struct type *context_type)
14f9c5c9 3630{
30b15541 3631 int fallback;
14f9c5c9 3632 int k;
4c4b4cd2 3633 int m; /* Number of hits */
14f9c5c9 3634
d2e4a39e 3635 m = 0;
30b15541
UW
3636 /* In the first pass of the loop, we only accept functions matching
3637 context_type. If none are found, we add a second pass of the loop
3638 where every function is accepted. */
3639 for (fallback = 0; m == 0 && fallback < 2; fallback++)
14f9c5c9
AS
3640 {
3641 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 3642 {
d12307c1 3643 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
4c4b4cd2 3644
d12307c1 3645 if (ada_args_match (syms[k].symbol, args, nargs)
30b15541 3646 && (fallback || return_match (type, context_type)))
4c4b4cd2
PH
3647 {
3648 syms[m] = syms[k];
3649 m += 1;
3650 }
3651 }
14f9c5c9
AS
3652 }
3653
3654 if (m == 0)
3655 return -1;
3656 else if (m > 1)
3657 {
323e0a4a 3658 printf_filtered (_("Multiple matches for %s\n"), name);
4c4b4cd2 3659 user_select_syms (syms, m, 1);
14f9c5c9
AS
3660 return 0;
3661 }
3662 return 0;
3663}
3664
4c4b4cd2
PH
3665/* Returns true (non-zero) iff decoded name N0 should appear before N1
3666 in a listing of choices during disambiguation (see sort_choices, below).
3667 The idea is that overloadings of a subprogram name from the
3668 same package should sort in their source order. We settle for ordering
3669 such symbols by their trailing number (__N or $N). */
3670
14f9c5c9 3671static int
0d5cff50 3672encoded_ordered_before (const char *N0, const char *N1)
14f9c5c9
AS
3673{
3674 if (N1 == NULL)
3675 return 0;
3676 else if (N0 == NULL)
3677 return 1;
3678 else
3679 {
3680 int k0, k1;
5b4ee69b 3681
d2e4a39e 3682 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3683 ;
d2e4a39e 3684 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3685 ;
d2e4a39e 3686 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3687 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3688 {
3689 int n0, n1;
5b4ee69b 3690
4c4b4cd2
PH
3691 n0 = k0;
3692 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3693 n0 -= 1;
3694 n1 = k1;
3695 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3696 n1 -= 1;
3697 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3698 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3699 }
14f9c5c9
AS
3700 return (strcmp (N0, N1) < 0);
3701 }
3702}
d2e4a39e 3703
4c4b4cd2
PH
3704/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3705 encoded names. */
3706
d2e4a39e 3707static void
d12307c1 3708sort_choices (struct block_symbol syms[], int nsyms)
14f9c5c9 3709{
4c4b4cd2 3710 int i;
5b4ee69b 3711
d2e4a39e 3712 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3713 {
d12307c1 3714 struct block_symbol sym = syms[i];
14f9c5c9
AS
3715 int j;
3716
d2e4a39e 3717 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2 3718 {
d12307c1
PMR
3719 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3720 SYMBOL_LINKAGE_NAME (sym.symbol)))
4c4b4cd2
PH
3721 break;
3722 syms[j + 1] = syms[j];
3723 }
d2e4a39e 3724 syms[j + 1] = sym;
14f9c5c9
AS
3725 }
3726}
3727
4c4b4cd2
PH
3728/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3729 by asking the user (if necessary), returning the number selected,
3730 and setting the first elements of SYMS items. Error if no symbols
3731 selected. */
14f9c5c9
AS
3732
3733/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3734 to be re-integrated one of these days. */
14f9c5c9
AS
3735
3736int
d12307c1 3737user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
14f9c5c9
AS
3738{
3739 int i;
d2e4a39e 3740 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3741 int n_chosen;
3742 int first_choice = (max_results == 1) ? 1 : 2;
717d2f5a 3743 const char *select_mode = multiple_symbols_select_mode ();
14f9c5c9
AS
3744
3745 if (max_results < 1)
323e0a4a 3746 error (_("Request to select 0 symbols!"));
14f9c5c9
AS
3747 if (nsyms <= 1)
3748 return nsyms;
3749
717d2f5a
JB
3750 if (select_mode == multiple_symbols_cancel)
3751 error (_("\
3752canceled because the command is ambiguous\n\
3753See set/show multiple-symbol."));
3754
3755 /* If select_mode is "all", then return all possible symbols.
3756 Only do that if more than one symbol can be selected, of course.
3757 Otherwise, display the menu as usual. */
3758 if (select_mode == multiple_symbols_all && max_results > 1)
3759 return nsyms;
3760
323e0a4a 3761 printf_unfiltered (_("[0] cancel\n"));
14f9c5c9 3762 if (max_results > 1)
323e0a4a 3763 printf_unfiltered (_("[1] all\n"));
14f9c5c9 3764
4c4b4cd2 3765 sort_choices (syms, nsyms);
14f9c5c9
AS
3766
3767 for (i = 0; i < nsyms; i += 1)
3768 {
d12307c1 3769 if (syms[i].symbol == NULL)
4c4b4cd2
PH
3770 continue;
3771
d12307c1 3772 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
4c4b4cd2 3773 {
76a01679 3774 struct symtab_and_line sal =
d12307c1 3775 find_function_start_sal (syms[i].symbol, 1);
5b4ee69b 3776
323e0a4a
AC
3777 if (sal.symtab == NULL)
3778 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3779 i + first_choice,
d12307c1 3780 SYMBOL_PRINT_NAME (syms[i].symbol),
323e0a4a
AC
3781 sal.line);
3782 else
3783 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
d12307c1 3784 SYMBOL_PRINT_NAME (syms[i].symbol),
05cba821
JK
3785 symtab_to_filename_for_display (sal.symtab),
3786 sal.line);
4c4b4cd2
PH
3787 continue;
3788 }
d2e4a39e 3789 else
4c4b4cd2
PH
3790 {
3791 int is_enumeral =
d12307c1
PMR
3792 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3793 && SYMBOL_TYPE (syms[i].symbol) != NULL
3794 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
1994afbf
DE
3795 struct symtab *symtab = NULL;
3796
d12307c1
PMR
3797 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3798 symtab = symbol_symtab (syms[i].symbol);
4c4b4cd2 3799
d12307c1 3800 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
323e0a4a 3801 printf_unfiltered (_("[%d] %s at %s:%d\n"),
4c4b4cd2 3802 i + first_choice,
d12307c1 3803 SYMBOL_PRINT_NAME (syms[i].symbol),
05cba821 3804 symtab_to_filename_for_display (symtab),
d12307c1 3805 SYMBOL_LINE (syms[i].symbol));
76a01679 3806 else if (is_enumeral
d12307c1 3807 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
4c4b4cd2 3808 {
a3f17187 3809 printf_unfiltered (("[%d] "), i + first_choice);
d12307c1 3810 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
79d43c61 3811 gdb_stdout, -1, 0, &type_print_raw_options);
323e0a4a 3812 printf_unfiltered (_("'(%s) (enumeral)\n"),
d12307c1 3813 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2
PH
3814 }
3815 else if (symtab != NULL)
3816 printf_unfiltered (is_enumeral
323e0a4a
AC
3817 ? _("[%d] %s in %s (enumeral)\n")
3818 : _("[%d] %s at %s:?\n"),
4c4b4cd2 3819 i + first_choice,
d12307c1 3820 SYMBOL_PRINT_NAME (syms[i].symbol),
05cba821 3821 symtab_to_filename_for_display (symtab));
4c4b4cd2
PH
3822 else
3823 printf_unfiltered (is_enumeral
323e0a4a
AC
3824 ? _("[%d] %s (enumeral)\n")
3825 : _("[%d] %s at ?\n"),
4c4b4cd2 3826 i + first_choice,
d12307c1 3827 SYMBOL_PRINT_NAME (syms[i].symbol));
4c4b4cd2 3828 }
14f9c5c9 3829 }
d2e4a39e 3830
14f9c5c9 3831 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3832 "overload-choice");
14f9c5c9
AS
3833
3834 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3835 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3836
3837 return n_chosen;
3838}
3839
3840/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3841 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3842 order in CHOICES[0 .. N-1], and return N.
3843
3844 The user types choices as a sequence of numbers on one line
3845 separated by blanks, encoding them as follows:
3846
4c4b4cd2 3847 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3848 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3849 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3850
4c4b4cd2 3851 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3852
3853 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3854 prompts (for use with the -f switch). */
14f9c5c9
AS
3855
3856int
d2e4a39e 3857get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3858 int is_all_choice, char *annotation_suffix)
14f9c5c9 3859{
d2e4a39e 3860 char *args;
0bcd0149 3861 char *prompt;
14f9c5c9
AS
3862 int n_chosen;
3863 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3864
14f9c5c9
AS
3865 prompt = getenv ("PS2");
3866 if (prompt == NULL)
0bcd0149 3867 prompt = "> ";
14f9c5c9 3868
0bcd0149 3869 args = command_line_input (prompt, 0, annotation_suffix);
d2e4a39e 3870
14f9c5c9 3871 if (args == NULL)
323e0a4a 3872 error_no_arg (_("one or more choice numbers"));
14f9c5c9
AS
3873
3874 n_chosen = 0;
76a01679 3875
4c4b4cd2
PH
3876 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3877 order, as given in args. Choices are validated. */
14f9c5c9
AS
3878 while (1)
3879 {
d2e4a39e 3880 char *args2;
14f9c5c9
AS
3881 int choice, j;
3882
0fcd72ba 3883 args = skip_spaces (args);
14f9c5c9 3884 if (*args == '\0' && n_chosen == 0)
323e0a4a 3885 error_no_arg (_("one or more choice numbers"));
14f9c5c9 3886 else if (*args == '\0')
4c4b4cd2 3887 break;
14f9c5c9
AS
3888
3889 choice = strtol (args, &args2, 10);
d2e4a39e 3890 if (args == args2 || choice < 0
4c4b4cd2 3891 || choice > n_choices + first_choice - 1)
323e0a4a 3892 error (_("Argument must be choice number"));
14f9c5c9
AS
3893 args = args2;
3894
d2e4a39e 3895 if (choice == 0)
323e0a4a 3896 error (_("cancelled"));
14f9c5c9
AS
3897
3898 if (choice < first_choice)
4c4b4cd2
PH
3899 {
3900 n_chosen = n_choices;
3901 for (j = 0; j < n_choices; j += 1)
3902 choices[j] = j;
3903 break;
3904 }
14f9c5c9
AS
3905 choice -= first_choice;
3906
d2e4a39e 3907 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3908 {
3909 }
14f9c5c9
AS
3910
3911 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3912 {
3913 int k;
5b4ee69b 3914
4c4b4cd2
PH
3915 for (k = n_chosen - 1; k > j; k -= 1)
3916 choices[k + 1] = choices[k];
3917 choices[j + 1] = choice;
3918 n_chosen += 1;
3919 }
14f9c5c9
AS
3920 }
3921
3922 if (n_chosen > max_results)
323e0a4a 3923 error (_("Select no more than %d of the above"), max_results);
d2e4a39e 3924
14f9c5c9
AS
3925 return n_chosen;
3926}
3927
4c4b4cd2
PH
3928/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3929 on the function identified by SYM and BLOCK, and taking NARGS
3930 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3931
3932static void
d2e4a39e 3933replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2 3934 int oplen, struct symbol *sym,
270140bd 3935 const struct block *block)
14f9c5c9
AS
3936{
3937 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3938 symbol, -oplen for operator being replaced). */
d2e4a39e 3939 struct expression *newexp = (struct expression *)
8c1a34e7 3940 xzalloc (sizeof (struct expression)
4c4b4cd2 3941 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3942 struct expression *exp = *expp;
14f9c5c9
AS
3943
3944 newexp->nelts = exp->nelts + 7 - oplen;
3945 newexp->language_defn = exp->language_defn;
3489610d 3946 newexp->gdbarch = exp->gdbarch;
14f9c5c9 3947 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3948 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3949 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3950
3951 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3952 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3953
3954 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3955 newexp->elts[pc + 4].block = block;
3956 newexp->elts[pc + 5].symbol = sym;
3957
3958 *expp = newexp;
aacb1f0a 3959 xfree (exp);
d2e4a39e 3960}
14f9c5c9
AS
3961
3962/* Type-class predicates */
3963
4c4b4cd2
PH
3964/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3965 or FLOAT). */
14f9c5c9
AS
3966
3967static int
d2e4a39e 3968numeric_type_p (struct type *type)
14f9c5c9
AS
3969{
3970 if (type == NULL)
3971 return 0;
d2e4a39e
AS
3972 else
3973 {
3974 switch (TYPE_CODE (type))
4c4b4cd2
PH
3975 {
3976 case TYPE_CODE_INT:
3977 case TYPE_CODE_FLT:
3978 return 1;
3979 case TYPE_CODE_RANGE:
3980 return (type == TYPE_TARGET_TYPE (type)
3981 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3982 default:
3983 return 0;
3984 }
d2e4a39e 3985 }
14f9c5c9
AS
3986}
3987
4c4b4cd2 3988/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3989
3990static int
d2e4a39e 3991integer_type_p (struct type *type)
14f9c5c9
AS
3992{
3993 if (type == NULL)
3994 return 0;
d2e4a39e
AS
3995 else
3996 {
3997 switch (TYPE_CODE (type))
4c4b4cd2
PH
3998 {
3999 case TYPE_CODE_INT:
4000 return 1;
4001 case TYPE_CODE_RANGE:
4002 return (type == TYPE_TARGET_TYPE (type)
4003 || integer_type_p (TYPE_TARGET_TYPE (type)));
4004 default:
4005 return 0;
4006 }
d2e4a39e 4007 }
14f9c5c9
AS
4008}
4009
4c4b4cd2 4010/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
4011
4012static int
d2e4a39e 4013scalar_type_p (struct type *type)
14f9c5c9
AS
4014{
4015 if (type == NULL)
4016 return 0;
d2e4a39e
AS
4017 else
4018 {
4019 switch (TYPE_CODE (type))
4c4b4cd2
PH
4020 {
4021 case TYPE_CODE_INT:
4022 case TYPE_CODE_RANGE:
4023 case TYPE_CODE_ENUM:
4024 case TYPE_CODE_FLT:
4025 return 1;
4026 default:
4027 return 0;
4028 }
d2e4a39e 4029 }
14f9c5c9
AS
4030}
4031
4c4b4cd2 4032/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
4033
4034static int
d2e4a39e 4035discrete_type_p (struct type *type)
14f9c5c9
AS
4036{
4037 if (type == NULL)
4038 return 0;
d2e4a39e
AS
4039 else
4040 {
4041 switch (TYPE_CODE (type))
4c4b4cd2
PH
4042 {
4043 case TYPE_CODE_INT:
4044 case TYPE_CODE_RANGE:
4045 case TYPE_CODE_ENUM:
872f0337 4046 case TYPE_CODE_BOOL:
4c4b4cd2
PH
4047 return 1;
4048 default:
4049 return 0;
4050 }
d2e4a39e 4051 }
14f9c5c9
AS
4052}
4053
4c4b4cd2
PH
4054/* Returns non-zero if OP with operands in the vector ARGS could be
4055 a user-defined function. Errs on the side of pre-defined operators
4056 (i.e., result 0). */
14f9c5c9
AS
4057
4058static int
d2e4a39e 4059possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 4060{
76a01679 4061 struct type *type0 =
df407dfe 4062 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
d2e4a39e 4063 struct type *type1 =
df407dfe 4064 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
d2e4a39e 4065
4c4b4cd2
PH
4066 if (type0 == NULL)
4067 return 0;
4068
14f9c5c9
AS
4069 switch (op)
4070 {
4071 default:
4072 return 0;
4073
4074 case BINOP_ADD:
4075 case BINOP_SUB:
4076 case BINOP_MUL:
4077 case BINOP_DIV:
d2e4a39e 4078 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
4079
4080 case BINOP_REM:
4081 case BINOP_MOD:
4082 case BINOP_BITWISE_AND:
4083 case BINOP_BITWISE_IOR:
4084 case BINOP_BITWISE_XOR:
d2e4a39e 4085 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4086
4087 case BINOP_EQUAL:
4088 case BINOP_NOTEQUAL:
4089 case BINOP_LESS:
4090 case BINOP_GTR:
4091 case BINOP_LEQ:
4092 case BINOP_GEQ:
d2e4a39e 4093 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
4094
4095 case BINOP_CONCAT:
ee90b9ab 4096 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
14f9c5c9
AS
4097
4098 case BINOP_EXP:
d2e4a39e 4099 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
4100
4101 case UNOP_NEG:
4102 case UNOP_PLUS:
4103 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
4104 case UNOP_ABS:
4105 return (!numeric_type_p (type0));
14f9c5c9
AS
4106
4107 }
4108}
4109\f
4c4b4cd2 4110 /* Renaming */
14f9c5c9 4111
aeb5907d
JB
4112/* NOTES:
4113
4114 1. In the following, we assume that a renaming type's name may
4115 have an ___XD suffix. It would be nice if this went away at some
4116 point.
4117 2. We handle both the (old) purely type-based representation of
4118 renamings and the (new) variable-based encoding. At some point,
4119 it is devoutly to be hoped that the former goes away
4120 (FIXME: hilfinger-2007-07-09).
4121 3. Subprogram renamings are not implemented, although the XRS
4122 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4123
4124/* If SYM encodes a renaming,
4125
4126 <renaming> renames <renamed entity>,
4127
4128 sets *LEN to the length of the renamed entity's name,
4129 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4130 the string describing the subcomponent selected from the renamed
0963b4bd 4131 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
aeb5907d
JB
4132 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4133 are undefined). Otherwise, returns a value indicating the category
4134 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4135 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4136 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4137 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4138 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4139 may be NULL, in which case they are not assigned.
4140
4141 [Currently, however, GCC does not generate subprogram renamings.] */
4142
4143enum ada_renaming_category
4144ada_parse_renaming (struct symbol *sym,
4145 const char **renamed_entity, int *len,
4146 const char **renaming_expr)
4147{
4148 enum ada_renaming_category kind;
4149 const char *info;
4150 const char *suffix;
4151
4152 if (sym == NULL)
4153 return ADA_NOT_RENAMING;
4154 switch (SYMBOL_CLASS (sym))
14f9c5c9 4155 {
aeb5907d
JB
4156 default:
4157 return ADA_NOT_RENAMING;
4158 case LOC_TYPEDEF:
4159 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4160 renamed_entity, len, renaming_expr);
4161 case LOC_LOCAL:
4162 case LOC_STATIC:
4163 case LOC_COMPUTED:
4164 case LOC_OPTIMIZED_OUT:
4165 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4166 if (info == NULL)
4167 return ADA_NOT_RENAMING;
4168 switch (info[5])
4169 {
4170 case '_':
4171 kind = ADA_OBJECT_RENAMING;
4172 info += 6;
4173 break;
4174 case 'E':
4175 kind = ADA_EXCEPTION_RENAMING;
4176 info += 7;
4177 break;
4178 case 'P':
4179 kind = ADA_PACKAGE_RENAMING;
4180 info += 7;
4181 break;
4182 case 'S':
4183 kind = ADA_SUBPROGRAM_RENAMING;
4184 info += 7;
4185 break;
4186 default:
4187 return ADA_NOT_RENAMING;
4188 }
14f9c5c9 4189 }
4c4b4cd2 4190
aeb5907d
JB
4191 if (renamed_entity != NULL)
4192 *renamed_entity = info;
4193 suffix = strstr (info, "___XE");
4194 if (suffix == NULL || suffix == info)
4195 return ADA_NOT_RENAMING;
4196 if (len != NULL)
4197 *len = strlen (info) - strlen (suffix);
4198 suffix += 5;
4199 if (renaming_expr != NULL)
4200 *renaming_expr = suffix;
4201 return kind;
4202}
4203
4204/* Assuming TYPE encodes a renaming according to the old encoding in
4205 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4206 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4207 ADA_NOT_RENAMING otherwise. */
4208static enum ada_renaming_category
4209parse_old_style_renaming (struct type *type,
4210 const char **renamed_entity, int *len,
4211 const char **renaming_expr)
4212{
4213 enum ada_renaming_category kind;
4214 const char *name;
4215 const char *info;
4216 const char *suffix;
14f9c5c9 4217
aeb5907d
JB
4218 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4219 || TYPE_NFIELDS (type) != 1)
4220 return ADA_NOT_RENAMING;
14f9c5c9 4221
aeb5907d
JB
4222 name = type_name_no_tag (type);
4223 if (name == NULL)
4224 return ADA_NOT_RENAMING;
4225
4226 name = strstr (name, "___XR");
4227 if (name == NULL)
4228 return ADA_NOT_RENAMING;
4229 switch (name[5])
4230 {
4231 case '\0':
4232 case '_':
4233 kind = ADA_OBJECT_RENAMING;
4234 break;
4235 case 'E':
4236 kind = ADA_EXCEPTION_RENAMING;
4237 break;
4238 case 'P':
4239 kind = ADA_PACKAGE_RENAMING;
4240 break;
4241 case 'S':
4242 kind = ADA_SUBPROGRAM_RENAMING;
4243 break;
4244 default:
4245 return ADA_NOT_RENAMING;
4246 }
14f9c5c9 4247
aeb5907d
JB
4248 info = TYPE_FIELD_NAME (type, 0);
4249 if (info == NULL)
4250 return ADA_NOT_RENAMING;
4251 if (renamed_entity != NULL)
4252 *renamed_entity = info;
4253 suffix = strstr (info, "___XE");
4254 if (renaming_expr != NULL)
4255 *renaming_expr = suffix + 5;
4256 if (suffix == NULL || suffix == info)
4257 return ADA_NOT_RENAMING;
4258 if (len != NULL)
4259 *len = suffix - info;
4260 return kind;
a5ee536b
JB
4261}
4262
4263/* Compute the value of the given RENAMING_SYM, which is expected to
4264 be a symbol encoding a renaming expression. BLOCK is the block
4265 used to evaluate the renaming. */
52ce6436 4266
a5ee536b
JB
4267static struct value *
4268ada_read_renaming_var_value (struct symbol *renaming_sym,
3977b71f 4269 const struct block *block)
a5ee536b 4270{
bbc13ae3 4271 const char *sym_name;
a5ee536b
JB
4272 struct expression *expr;
4273 struct value *value;
4274 struct cleanup *old_chain = NULL;
4275
bbc13ae3 4276 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
1bb9788d 4277 expr = parse_exp_1 (&sym_name, 0, block, 0);
bbc13ae3 4278 old_chain = make_cleanup (free_current_contents, &expr);
a5ee536b
JB
4279 value = evaluate_expression (expr);
4280
4281 do_cleanups (old_chain);
4282 return value;
4283}
14f9c5c9 4284\f
d2e4a39e 4285
4c4b4cd2 4286 /* Evaluation: Function Calls */
14f9c5c9 4287
4c4b4cd2 4288/* Return an lvalue containing the value VAL. This is the identity on
40bc484c
JB
4289 lvalues, and otherwise has the side-effect of allocating memory
4290 in the inferior where a copy of the value contents is copied. */
14f9c5c9 4291
d2e4a39e 4292static struct value *
40bc484c 4293ensure_lval (struct value *val)
14f9c5c9 4294{
40bc484c
JB
4295 if (VALUE_LVAL (val) == not_lval
4296 || VALUE_LVAL (val) == lval_internalvar)
c3e5cd34 4297 {
df407dfe 4298 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
40bc484c
JB
4299 const CORE_ADDR addr =
4300 value_as_long (value_allocate_space_in_inferior (len));
c3e5cd34 4301
40bc484c 4302 set_value_address (val, addr);
a84a8a0d 4303 VALUE_LVAL (val) = lval_memory;
40bc484c 4304 write_memory (addr, value_contents (val), len);
c3e5cd34 4305 }
14f9c5c9
AS
4306
4307 return val;
4308}
4309
4310/* Return the value ACTUAL, converted to be an appropriate value for a
4311 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4312 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 4313 values not residing in memory, updating it as needed. */
14f9c5c9 4314
a93c0eb6 4315struct value *
40bc484c 4316ada_convert_actual (struct value *actual, struct type *formal_type0)
14f9c5c9 4317{
df407dfe 4318 struct type *actual_type = ada_check_typedef (value_type (actual));
61ee279c 4319 struct type *formal_type = ada_check_typedef (formal_type0);
d2e4a39e
AS
4320 struct type *formal_target =
4321 TYPE_CODE (formal_type) == TYPE_CODE_PTR
61ee279c 4322 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
d2e4a39e
AS
4323 struct type *actual_target =
4324 TYPE_CODE (actual_type) == TYPE_CODE_PTR
61ee279c 4325 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 4326
4c4b4cd2 4327 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9 4328 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
40bc484c 4329 return make_array_descriptor (formal_type, actual);
a84a8a0d
JB
4330 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4331 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
14f9c5c9 4332 {
a84a8a0d 4333 struct value *result;
5b4ee69b 4334
14f9c5c9 4335 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2 4336 && ada_is_array_descriptor_type (actual_target))
a84a8a0d 4337 result = desc_data (actual);
14f9c5c9 4338 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
4339 {
4340 if (VALUE_LVAL (actual) != lval_memory)
4341 {
4342 struct value *val;
5b4ee69b 4343
df407dfe 4344 actual_type = ada_check_typedef (value_type (actual));
4c4b4cd2 4345 val = allocate_value (actual_type);
990a07ab 4346 memcpy ((char *) value_contents_raw (val),
0fd88904 4347 (char *) value_contents (actual),
4c4b4cd2 4348 TYPE_LENGTH (actual_type));
40bc484c 4349 actual = ensure_lval (val);
4c4b4cd2 4350 }
a84a8a0d 4351 result = value_addr (actual);
4c4b4cd2 4352 }
a84a8a0d
JB
4353 else
4354 return actual;
b1af9e97 4355 return value_cast_pointers (formal_type, result, 0);
14f9c5c9
AS
4356 }
4357 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4358 return ada_value_ind (actual);
8344af1e
JB
4359 else if (ada_is_aligner_type (formal_type))
4360 {
4361 /* We need to turn this parameter into an aligner type
4362 as well. */
4363 struct value *aligner = allocate_value (formal_type);
4364 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4365
4366 value_assign_to_component (aligner, component, actual);
4367 return aligner;
4368 }
14f9c5c9
AS
4369
4370 return actual;
4371}
4372
438c98a1
JB
4373/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4374 type TYPE. This is usually an inefficient no-op except on some targets
4375 (such as AVR) where the representation of a pointer and an address
4376 differs. */
4377
4378static CORE_ADDR
4379value_pointer (struct value *value, struct type *type)
4380{
4381 struct gdbarch *gdbarch = get_type_arch (type);
4382 unsigned len = TYPE_LENGTH (type);
4383 gdb_byte *buf = alloca (len);
4384 CORE_ADDR addr;
4385
4386 addr = value_address (value);
4387 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4388 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4389 return addr;
4390}
4391
14f9c5c9 4392
4c4b4cd2
PH
4393/* Push a descriptor of type TYPE for array value ARR on the stack at
4394 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 4395 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
4396 to-descriptor type rather than a descriptor type), a struct value *
4397 representing a pointer to this descriptor. */
14f9c5c9 4398
d2e4a39e 4399static struct value *
40bc484c 4400make_array_descriptor (struct type *type, struct value *arr)
14f9c5c9 4401{
d2e4a39e
AS
4402 struct type *bounds_type = desc_bounds_type (type);
4403 struct type *desc_type = desc_base_type (type);
4404 struct value *descriptor = allocate_value (desc_type);
4405 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 4406 int i;
d2e4a39e 4407
0963b4bd
MS
4408 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4409 i > 0; i -= 1)
14f9c5c9 4410 {
19f220c3
JK
4411 modify_field (value_type (bounds), value_contents_writeable (bounds),
4412 ada_array_bound (arr, i, 0),
4413 desc_bound_bitpos (bounds_type, i, 0),
4414 desc_bound_bitsize (bounds_type, i, 0));
4415 modify_field (value_type (bounds), value_contents_writeable (bounds),
4416 ada_array_bound (arr, i, 1),
4417 desc_bound_bitpos (bounds_type, i, 1),
4418 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 4419 }
d2e4a39e 4420
40bc484c 4421 bounds = ensure_lval (bounds);
d2e4a39e 4422
19f220c3
JK
4423 modify_field (value_type (descriptor),
4424 value_contents_writeable (descriptor),
4425 value_pointer (ensure_lval (arr),
4426 TYPE_FIELD_TYPE (desc_type, 0)),
4427 fat_pntr_data_bitpos (desc_type),
4428 fat_pntr_data_bitsize (desc_type));
4429
4430 modify_field (value_type (descriptor),
4431 value_contents_writeable (descriptor),
4432 value_pointer (bounds,
4433 TYPE_FIELD_TYPE (desc_type, 1)),
4434 fat_pntr_bounds_bitpos (desc_type),
4435 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 4436
40bc484c 4437 descriptor = ensure_lval (descriptor);
14f9c5c9
AS
4438
4439 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4440 return value_addr (descriptor);
4441 else
4442 return descriptor;
4443}
14f9c5c9 4444\f
3d9434b5
JB
4445 /* Symbol Cache Module */
4446
3d9434b5 4447/* Performance measurements made as of 2010-01-15 indicate that
ee01b665 4448 this cache does bring some noticeable improvements. Depending
3d9434b5
JB
4449 on the type of entity being printed, the cache can make it as much
4450 as an order of magnitude faster than without it.
4451
4452 The descriptive type DWARF extension has significantly reduced
4453 the need for this cache, at least when DWARF is being used. However,
4454 even in this case, some expensive name-based symbol searches are still
4455 sometimes necessary - to find an XVZ variable, mostly. */
4456
ee01b665 4457/* Initialize the contents of SYM_CACHE. */
3d9434b5 4458
ee01b665
JB
4459static void
4460ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4461{
4462 obstack_init (&sym_cache->cache_space);
4463 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4464}
3d9434b5 4465
ee01b665
JB
4466/* Free the memory used by SYM_CACHE. */
4467
4468static void
4469ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
3d9434b5 4470{
ee01b665
JB
4471 obstack_free (&sym_cache->cache_space, NULL);
4472 xfree (sym_cache);
4473}
3d9434b5 4474
ee01b665
JB
4475/* Return the symbol cache associated to the given program space PSPACE.
4476 If not allocated for this PSPACE yet, allocate and initialize one. */
3d9434b5 4477
ee01b665
JB
4478static struct ada_symbol_cache *
4479ada_get_symbol_cache (struct program_space *pspace)
4480{
4481 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
ee01b665 4482
66c168ae 4483 if (pspace_data->sym_cache == NULL)
ee01b665 4484 {
66c168ae
JB
4485 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4486 ada_init_symbol_cache (pspace_data->sym_cache);
ee01b665
JB
4487 }
4488
66c168ae 4489 return pspace_data->sym_cache;
ee01b665 4490}
3d9434b5
JB
4491
4492/* Clear all entries from the symbol cache. */
4493
4494static void
4495ada_clear_symbol_cache (void)
4496{
ee01b665
JB
4497 struct ada_symbol_cache *sym_cache
4498 = ada_get_symbol_cache (current_program_space);
4499
4500 obstack_free (&sym_cache->cache_space, NULL);
4501 ada_init_symbol_cache (sym_cache);
3d9434b5
JB
4502}
4503
fe978cb0 4504/* Search our cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4505 Return it if found, or NULL otherwise. */
4506
4507static struct cache_entry **
fe978cb0 4508find_entry (const char *name, domain_enum domain)
3d9434b5 4509{
ee01b665
JB
4510 struct ada_symbol_cache *sym_cache
4511 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4512 int h = msymbol_hash (name) % HASH_SIZE;
4513 struct cache_entry **e;
4514
ee01b665 4515 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
3d9434b5 4516 {
fe978cb0 4517 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
3d9434b5
JB
4518 return e;
4519 }
4520 return NULL;
4521}
4522
fe978cb0 4523/* Search the symbol cache for an entry matching NAME and DOMAIN.
3d9434b5
JB
4524 Return 1 if found, 0 otherwise.
4525
4526 If an entry was found and SYM is not NULL, set *SYM to the entry's
4527 SYM. Same principle for BLOCK if not NULL. */
96d887e8 4528
96d887e8 4529static int
fe978cb0 4530lookup_cached_symbol (const char *name, domain_enum domain,
f0c5f9b2 4531 struct symbol **sym, const struct block **block)
96d887e8 4532{
fe978cb0 4533 struct cache_entry **e = find_entry (name, domain);
3d9434b5
JB
4534
4535 if (e == NULL)
4536 return 0;
4537 if (sym != NULL)
4538 *sym = (*e)->sym;
4539 if (block != NULL)
4540 *block = (*e)->block;
4541 return 1;
96d887e8
PH
4542}
4543
3d9434b5 4544/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
fe978cb0 4545 in domain DOMAIN, save this result in our symbol cache. */
3d9434b5 4546
96d887e8 4547static void
fe978cb0 4548cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
270140bd 4549 const struct block *block)
96d887e8 4550{
ee01b665
JB
4551 struct ada_symbol_cache *sym_cache
4552 = ada_get_symbol_cache (current_program_space);
3d9434b5
JB
4553 int h;
4554 char *copy;
4555 struct cache_entry *e;
4556
1994afbf
DE
4557 /* Symbols for builtin types don't have a block.
4558 For now don't cache such symbols. */
4559 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4560 return;
4561
3d9434b5
JB
4562 /* If the symbol is a local symbol, then do not cache it, as a search
4563 for that symbol depends on the context. To determine whether
4564 the symbol is local or not, we check the block where we found it
4565 against the global and static blocks of its associated symtab. */
4566 if (sym
08be3fe3 4567 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4568 GLOBAL_BLOCK) != block
08be3fe3 4569 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
439247b6 4570 STATIC_BLOCK) != block)
3d9434b5
JB
4571 return;
4572
4573 h = msymbol_hash (name) % HASH_SIZE;
ee01b665
JB
4574 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4575 sizeof (*e));
4576 e->next = sym_cache->root[h];
4577 sym_cache->root[h] = e;
4578 e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
3d9434b5
JB
4579 strcpy (copy, name);
4580 e->sym = sym;
fe978cb0 4581 e->domain = domain;
3d9434b5 4582 e->block = block;
96d887e8 4583}
4c4b4cd2
PH
4584\f
4585 /* Symbol Lookup */
4586
c0431670
JB
4587/* Return nonzero if wild matching should be used when searching for
4588 all symbols matching LOOKUP_NAME.
4589
4590 LOOKUP_NAME is expected to be a symbol name after transformation
4591 for Ada lookups (see ada_name_for_lookup). */
4592
4593static int
4594should_use_wild_match (const char *lookup_name)
4595{
4596 return (strstr (lookup_name, "__") == NULL);
4597}
4598
4c4b4cd2
PH
4599/* Return the result of a standard (literal, C-like) lookup of NAME in
4600 given DOMAIN, visible from lexical block BLOCK. */
4601
4602static struct symbol *
4603standard_lookup (const char *name, const struct block *block,
4604 domain_enum domain)
4605{
acbd605d 4606 /* Initialize it just to avoid a GCC false warning. */
d12307c1 4607 struct block_symbol sym = {NULL, NULL};
4c4b4cd2 4608
d12307c1
PMR
4609 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4610 return sym.symbol;
2570f2b7 4611 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
d12307c1
PMR
4612 cache_symbol (name, domain, sym.symbol, sym.block);
4613 return sym.symbol;
4c4b4cd2
PH
4614}
4615
4616
4617/* Non-zero iff there is at least one non-function/non-enumeral symbol
4618 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4619 since they contend in overloading in the same way. */
4620static int
d12307c1 4621is_nonfunction (struct block_symbol syms[], int n)
4c4b4cd2
PH
4622{
4623 int i;
4624
4625 for (i = 0; i < n; i += 1)
d12307c1
PMR
4626 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4627 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4628 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
14f9c5c9
AS
4629 return 1;
4630
4631 return 0;
4632}
4633
4634/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 4635 struct types. Otherwise, they may not. */
14f9c5c9
AS
4636
4637static int
d2e4a39e 4638equiv_types (struct type *type0, struct type *type1)
14f9c5c9 4639{
d2e4a39e 4640 if (type0 == type1)
14f9c5c9 4641 return 1;
d2e4a39e 4642 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
4643 || TYPE_CODE (type0) != TYPE_CODE (type1))
4644 return 0;
d2e4a39e 4645 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
4646 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4647 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 4648 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 4649 return 1;
d2e4a39e 4650
14f9c5c9
AS
4651 return 0;
4652}
4653
4654/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 4655 no more defined than that of SYM1. */
14f9c5c9
AS
4656
4657static int
d2e4a39e 4658lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
4659{
4660 if (sym0 == sym1)
4661 return 1;
176620f1 4662 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
4663 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4664 return 0;
4665
d2e4a39e 4666 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
4667 {
4668 case LOC_UNDEF:
4669 return 1;
4670 case LOC_TYPEDEF:
4671 {
4c4b4cd2
PH
4672 struct type *type0 = SYMBOL_TYPE (sym0);
4673 struct type *type1 = SYMBOL_TYPE (sym1);
0d5cff50
DE
4674 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4675 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4c4b4cd2 4676 int len0 = strlen (name0);
5b4ee69b 4677
4c4b4cd2
PH
4678 return
4679 TYPE_CODE (type0) == TYPE_CODE (type1)
4680 && (equiv_types (type0, type1)
4681 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
61012eef 4682 && startswith (name1 + len0, "___XV")));
14f9c5c9
AS
4683 }
4684 case LOC_CONST:
4685 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 4686 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
4687 default:
4688 return 0;
14f9c5c9
AS
4689 }
4690}
4691
d12307c1 4692/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4c4b4cd2 4693 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
4694
4695static void
76a01679
JB
4696add_defn_to_vec (struct obstack *obstackp,
4697 struct symbol *sym,
f0c5f9b2 4698 const struct block *block)
14f9c5c9
AS
4699{
4700 int i;
d12307c1 4701 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 4702
529cad9c
PH
4703 /* Do not try to complete stub types, as the debugger is probably
4704 already scanning all symbols matching a certain name at the
4705 time when this function is called. Trying to replace the stub
4706 type by its associated full type will cause us to restart a scan
4707 which may lead to an infinite recursion. Instead, the client
4708 collecting the matching symbols will end up collecting several
4709 matches, with at least one of them complete. It can then filter
4710 out the stub ones if needed. */
4711
4c4b4cd2
PH
4712 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4713 {
d12307c1 4714 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4c4b4cd2 4715 return;
d12307c1 4716 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4c4b4cd2 4717 {
d12307c1 4718 prevDefns[i].symbol = sym;
4c4b4cd2 4719 prevDefns[i].block = block;
4c4b4cd2 4720 return;
76a01679 4721 }
4c4b4cd2
PH
4722 }
4723
4724 {
d12307c1 4725 struct block_symbol info;
4c4b4cd2 4726
d12307c1 4727 info.symbol = sym;
4c4b4cd2 4728 info.block = block;
d12307c1 4729 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4c4b4cd2
PH
4730 }
4731}
4732
d12307c1
PMR
4733/* Number of block_symbol structures currently collected in current vector in
4734 OBSTACKP. */
4c4b4cd2 4735
76a01679
JB
4736static int
4737num_defns_collected (struct obstack *obstackp)
4c4b4cd2 4738{
d12307c1 4739 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4c4b4cd2
PH
4740}
4741
d12307c1
PMR
4742/* Vector of block_symbol structures currently collected in current vector in
4743 OBSTACKP. If FINISH, close off the vector and return its final address. */
4c4b4cd2 4744
d12307c1 4745static struct block_symbol *
4c4b4cd2
PH
4746defns_collected (struct obstack *obstackp, int finish)
4747{
4748 if (finish)
4749 return obstack_finish (obstackp);
4750 else
d12307c1 4751 return (struct block_symbol *) obstack_base (obstackp);
4c4b4cd2
PH
4752}
4753
7c7b6655
TT
4754/* Return a bound minimal symbol matching NAME according to Ada
4755 decoding rules. Returns an invalid symbol if there is no such
4756 minimal symbol. Names prefixed with "standard__" are handled
4757 specially: "standard__" is first stripped off, and only static and
4758 global symbols are searched. */
4c4b4cd2 4759
7c7b6655 4760struct bound_minimal_symbol
96d887e8 4761ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4762{
7c7b6655 4763 struct bound_minimal_symbol result;
4c4b4cd2 4764 struct objfile *objfile;
96d887e8 4765 struct minimal_symbol *msymbol;
dc4024cd 4766 const int wild_match_p = should_use_wild_match (name);
4c4b4cd2 4767
7c7b6655
TT
4768 memset (&result, 0, sizeof (result));
4769
c0431670
JB
4770 /* Special case: If the user specifies a symbol name inside package
4771 Standard, do a non-wild matching of the symbol name without
4772 the "standard__" prefix. This was primarily introduced in order
4773 to allow the user to specifically access the standard exceptions
4774 using, for instance, Standard.Constraint_Error when Constraint_Error
4775 is ambiguous (due to the user defining its own Constraint_Error
4776 entity inside its program). */
61012eef 4777 if (startswith (name, "standard__"))
c0431670 4778 name += sizeof ("standard__") - 1;
4c4b4cd2 4779
96d887e8
PH
4780 ALL_MSYMBOLS (objfile, msymbol)
4781 {
efd66ac6 4782 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
96d887e8 4783 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
7c7b6655
TT
4784 {
4785 result.minsym = msymbol;
4786 result.objfile = objfile;
4787 break;
4788 }
96d887e8 4789 }
4c4b4cd2 4790
7c7b6655 4791 return result;
96d887e8 4792}
4c4b4cd2 4793
96d887e8
PH
4794/* For all subprograms that statically enclose the subprogram of the
4795 selected frame, add symbols matching identifier NAME in DOMAIN
4796 and their blocks to the list of data in OBSTACKP, as for
48b78332
JB
4797 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4798 with a wildcard prefix. */
4c4b4cd2 4799
96d887e8
PH
4800static void
4801add_symbols_from_enclosing_procs (struct obstack *obstackp,
fe978cb0 4802 const char *name, domain_enum domain,
48b78332 4803 int wild_match_p)
96d887e8 4804{
96d887e8 4805}
14f9c5c9 4806
96d887e8
PH
4807/* True if TYPE is definitely an artificial type supplied to a symbol
4808 for which no debugging information was given in the symbol file. */
14f9c5c9 4809
96d887e8
PH
4810static int
4811is_nondebugging_type (struct type *type)
4812{
0d5cff50 4813 const char *name = ada_type_name (type);
5b4ee69b 4814
96d887e8
PH
4815 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4816}
4c4b4cd2 4817
8f17729f
JB
4818/* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4819 that are deemed "identical" for practical purposes.
4820
4821 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4822 types and that their number of enumerals is identical (in other
4823 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4824
4825static int
4826ada_identical_enum_types_p (struct type *type1, struct type *type2)
4827{
4828 int i;
4829
4830 /* The heuristic we use here is fairly conservative. We consider
4831 that 2 enumerate types are identical if they have the same
4832 number of enumerals and that all enumerals have the same
4833 underlying value and name. */
4834
4835 /* All enums in the type should have an identical underlying value. */
4836 for (i = 0; i < TYPE_NFIELDS (type1); i++)
14e75d8e 4837 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
8f17729f
JB
4838 return 0;
4839
4840 /* All enumerals should also have the same name (modulo any numerical
4841 suffix). */
4842 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4843 {
0d5cff50
DE
4844 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4845 const char *name_2 = TYPE_FIELD_NAME (type2, i);
8f17729f
JB
4846 int len_1 = strlen (name_1);
4847 int len_2 = strlen (name_2);
4848
4849 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4850 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4851 if (len_1 != len_2
4852 || strncmp (TYPE_FIELD_NAME (type1, i),
4853 TYPE_FIELD_NAME (type2, i),
4854 len_1) != 0)
4855 return 0;
4856 }
4857
4858 return 1;
4859}
4860
4861/* Return nonzero if all the symbols in SYMS are all enumeral symbols
4862 that are deemed "identical" for practical purposes. Sometimes,
4863 enumerals are not strictly identical, but their types are so similar
4864 that they can be considered identical.
4865
4866 For instance, consider the following code:
4867
4868 type Color is (Black, Red, Green, Blue, White);
4869 type RGB_Color is new Color range Red .. Blue;
4870
4871 Type RGB_Color is a subrange of an implicit type which is a copy
4872 of type Color. If we call that implicit type RGB_ColorB ("B" is
4873 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4874 As a result, when an expression references any of the enumeral
4875 by name (Eg. "print green"), the expression is technically
4876 ambiguous and the user should be asked to disambiguate. But
4877 doing so would only hinder the user, since it wouldn't matter
4878 what choice he makes, the outcome would always be the same.
4879 So, for practical purposes, we consider them as the same. */
4880
4881static int
d12307c1 4882symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
8f17729f
JB
4883{
4884 int i;
4885
4886 /* Before performing a thorough comparison check of each type,
4887 we perform a series of inexpensive checks. We expect that these
4888 checks will quickly fail in the vast majority of cases, and thus
4889 help prevent the unnecessary use of a more expensive comparison.
4890 Said comparison also expects us to make some of these checks
4891 (see ada_identical_enum_types_p). */
4892
4893 /* Quick check: All symbols should have an enum type. */
4894 for (i = 0; i < nsyms; i++)
d12307c1 4895 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
8f17729f
JB
4896 return 0;
4897
4898 /* Quick check: They should all have the same value. */
4899 for (i = 1; i < nsyms; i++)
d12307c1 4900 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
8f17729f
JB
4901 return 0;
4902
4903 /* Quick check: They should all have the same number of enumerals. */
4904 for (i = 1; i < nsyms; i++)
d12307c1
PMR
4905 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
4906 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
4907 return 0;
4908
4909 /* All the sanity checks passed, so we might have a set of
4910 identical enumeration types. Perform a more complete
4911 comparison of the type of each symbol. */
4912 for (i = 1; i < nsyms; i++)
d12307c1
PMR
4913 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
4914 SYMBOL_TYPE (syms[0].symbol)))
8f17729f
JB
4915 return 0;
4916
4917 return 1;
4918}
4919
96d887e8
PH
4920/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4921 duplicate other symbols in the list (The only case I know of where
4922 this happens is when object files containing stabs-in-ecoff are
4923 linked with files containing ordinary ecoff debugging symbols (or no
4924 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4925 Returns the number of items in the modified list. */
4c4b4cd2 4926
96d887e8 4927static int
d12307c1 4928remove_extra_symbols (struct block_symbol *syms, int nsyms)
96d887e8
PH
4929{
4930 int i, j;
4c4b4cd2 4931
8f17729f
JB
4932 /* We should never be called with less than 2 symbols, as there
4933 cannot be any extra symbol in that case. But it's easy to
4934 handle, since we have nothing to do in that case. */
4935 if (nsyms < 2)
4936 return nsyms;
4937
96d887e8
PH
4938 i = 0;
4939 while (i < nsyms)
4940 {
a35ddb44 4941 int remove_p = 0;
339c13b6
JB
4942
4943 /* If two symbols have the same name and one of them is a stub type,
4944 the get rid of the stub. */
4945
d12307c1
PMR
4946 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
4947 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
339c13b6
JB
4948 {
4949 for (j = 0; j < nsyms; j++)
4950 {
4951 if (j != i
d12307c1
PMR
4952 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
4953 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
4954 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
4955 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
a35ddb44 4956 remove_p = 1;
339c13b6
JB
4957 }
4958 }
4959
4960 /* Two symbols with the same name, same class and same address
4961 should be identical. */
4962
d12307c1
PMR
4963 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
4964 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
4965 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
96d887e8
PH
4966 {
4967 for (j = 0; j < nsyms; j += 1)
4968 {
4969 if (i != j
d12307c1
PMR
4970 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
4971 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
4972 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
4973 && SYMBOL_CLASS (syms[i].symbol)
4974 == SYMBOL_CLASS (syms[j].symbol)
4975 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
4976 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
a35ddb44 4977 remove_p = 1;
4c4b4cd2 4978 }
4c4b4cd2 4979 }
339c13b6 4980
a35ddb44 4981 if (remove_p)
339c13b6
JB
4982 {
4983 for (j = i + 1; j < nsyms; j += 1)
4984 syms[j - 1] = syms[j];
4985 nsyms -= 1;
4986 }
4987
96d887e8 4988 i += 1;
14f9c5c9 4989 }
8f17729f
JB
4990
4991 /* If all the remaining symbols are identical enumerals, then
4992 just keep the first one and discard the rest.
4993
4994 Unlike what we did previously, we do not discard any entry
4995 unless they are ALL identical. This is because the symbol
4996 comparison is not a strict comparison, but rather a practical
4997 comparison. If all symbols are considered identical, then
4998 we can just go ahead and use the first one and discard the rest.
4999 But if we cannot reduce the list to a single element, we have
5000 to ask the user to disambiguate anyways. And if we have to
5001 present a multiple-choice menu, it's less confusing if the list
5002 isn't missing some choices that were identical and yet distinct. */
5003 if (symbols_are_identical_enums (syms, nsyms))
5004 nsyms = 1;
5005
96d887e8 5006 return nsyms;
14f9c5c9
AS
5007}
5008
96d887e8
PH
5009/* Given a type that corresponds to a renaming entity, use the type name
5010 to extract the scope (package name or function name, fully qualified,
5011 and following the GNAT encoding convention) where this renaming has been
5012 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 5013
96d887e8
PH
5014static char *
5015xget_renaming_scope (struct type *renaming_type)
14f9c5c9 5016{
96d887e8 5017 /* The renaming types adhere to the following convention:
0963b4bd 5018 <scope>__<rename>___<XR extension>.
96d887e8
PH
5019 So, to extract the scope, we search for the "___XR" extension,
5020 and then backtrack until we find the first "__". */
76a01679 5021
96d887e8
PH
5022 const char *name = type_name_no_tag (renaming_type);
5023 char *suffix = strstr (name, "___XR");
5024 char *last;
5025 int scope_len;
5026 char *scope;
14f9c5c9 5027
96d887e8
PH
5028 /* Now, backtrack a bit until we find the first "__". Start looking
5029 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 5030
96d887e8
PH
5031 for (last = suffix - 3; last > name; last--)
5032 if (last[0] == '_' && last[1] == '_')
5033 break;
76a01679 5034
96d887e8 5035 /* Make a copy of scope and return it. */
14f9c5c9 5036
96d887e8
PH
5037 scope_len = last - name;
5038 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 5039
96d887e8
PH
5040 strncpy (scope, name, scope_len);
5041 scope[scope_len] = '\0';
4c4b4cd2 5042
96d887e8 5043 return scope;
4c4b4cd2
PH
5044}
5045
96d887e8 5046/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 5047
96d887e8
PH
5048static int
5049is_package_name (const char *name)
4c4b4cd2 5050{
96d887e8
PH
5051 /* Here, We take advantage of the fact that no symbols are generated
5052 for packages, while symbols are generated for each function.
5053 So the condition for NAME represent a package becomes equivalent
5054 to NAME not existing in our list of symbols. There is only one
5055 small complication with library-level functions (see below). */
4c4b4cd2 5056
96d887e8 5057 char *fun_name;
76a01679 5058
96d887e8
PH
5059 /* If it is a function that has not been defined at library level,
5060 then we should be able to look it up in the symbols. */
5061 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5062 return 0;
14f9c5c9 5063
96d887e8
PH
5064 /* Library-level function names start with "_ada_". See if function
5065 "_ada_" followed by NAME can be found. */
14f9c5c9 5066
96d887e8 5067 /* Do a quick check that NAME does not contain "__", since library-level
e1d5a0d2 5068 functions names cannot contain "__" in them. */
96d887e8
PH
5069 if (strstr (name, "__") != NULL)
5070 return 0;
4c4b4cd2 5071
b435e160 5072 fun_name = xstrprintf ("_ada_%s", name);
14f9c5c9 5073
96d887e8
PH
5074 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5075}
14f9c5c9 5076
96d887e8 5077/* Return nonzero if SYM corresponds to a renaming entity that is
aeb5907d 5078 not visible from FUNCTION_NAME. */
14f9c5c9 5079
96d887e8 5080static int
0d5cff50 5081old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
96d887e8 5082{
aeb5907d 5083 char *scope;
1509e573 5084 struct cleanup *old_chain;
aeb5907d
JB
5085
5086 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5087 return 0;
5088
5089 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
1509e573 5090 old_chain = make_cleanup (xfree, scope);
14f9c5c9 5091
96d887e8
PH
5092 /* If the rename has been defined in a package, then it is visible. */
5093 if (is_package_name (scope))
1509e573
JB
5094 {
5095 do_cleanups (old_chain);
5096 return 0;
5097 }
14f9c5c9 5098
96d887e8
PH
5099 /* Check that the rename is in the current function scope by checking
5100 that its name starts with SCOPE. */
76a01679 5101
96d887e8
PH
5102 /* If the function name starts with "_ada_", it means that it is
5103 a library-level function. Strip this prefix before doing the
5104 comparison, as the encoding for the renaming does not contain
5105 this prefix. */
61012eef 5106 if (startswith (function_name, "_ada_"))
96d887e8 5107 function_name += 5;
f26caa11 5108
1509e573 5109 {
61012eef 5110 int is_invisible = !startswith (function_name, scope);
1509e573
JB
5111
5112 do_cleanups (old_chain);
5113 return is_invisible;
5114 }
f26caa11
PH
5115}
5116
aeb5907d
JB
5117/* Remove entries from SYMS that corresponds to a renaming entity that
5118 is not visible from the function associated with CURRENT_BLOCK or
5119 that is superfluous due to the presence of more specific renaming
5120 information. Places surviving symbols in the initial entries of
5121 SYMS and returns the number of surviving symbols.
96d887e8
PH
5122
5123 Rationale:
aeb5907d
JB
5124 First, in cases where an object renaming is implemented as a
5125 reference variable, GNAT may produce both the actual reference
5126 variable and the renaming encoding. In this case, we discard the
5127 latter.
5128
5129 Second, GNAT emits a type following a specified encoding for each renaming
96d887e8
PH
5130 entity. Unfortunately, STABS currently does not support the definition
5131 of types that are local to a given lexical block, so all renamings types
5132 are emitted at library level. As a consequence, if an application
5133 contains two renaming entities using the same name, and a user tries to
5134 print the value of one of these entities, the result of the ada symbol
5135 lookup will also contain the wrong renaming type.
f26caa11 5136
96d887e8
PH
5137 This function partially covers for this limitation by attempting to
5138 remove from the SYMS list renaming symbols that should be visible
5139 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5140 method with the current information available. The implementation
5141 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5142
5143 - When the user tries to print a rename in a function while there
5144 is another rename entity defined in a package: Normally, the
5145 rename in the function has precedence over the rename in the
5146 package, so the latter should be removed from the list. This is
5147 currently not the case.
5148
5149 - This function will incorrectly remove valid renames if
5150 the CURRENT_BLOCK corresponds to a function which symbol name
5151 has been changed by an "Export" pragma. As a consequence,
5152 the user will be unable to print such rename entities. */
4c4b4cd2 5153
14f9c5c9 5154static int
d12307c1 5155remove_irrelevant_renamings (struct block_symbol *syms,
aeb5907d 5156 int nsyms, const struct block *current_block)
4c4b4cd2
PH
5157{
5158 struct symbol *current_function;
0d5cff50 5159 const char *current_function_name;
4c4b4cd2 5160 int i;
aeb5907d
JB
5161 int is_new_style_renaming;
5162
5163 /* If there is both a renaming foo___XR... encoded as a variable and
5164 a simple variable foo in the same block, discard the latter.
0963b4bd 5165 First, zero out such symbols, then compress. */
aeb5907d
JB
5166 is_new_style_renaming = 0;
5167 for (i = 0; i < nsyms; i += 1)
5168 {
d12307c1 5169 struct symbol *sym = syms[i].symbol;
270140bd 5170 const struct block *block = syms[i].block;
aeb5907d
JB
5171 const char *name;
5172 const char *suffix;
5173
5174 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5175 continue;
5176 name = SYMBOL_LINKAGE_NAME (sym);
5177 suffix = strstr (name, "___XR");
5178
5179 if (suffix != NULL)
5180 {
5181 int name_len = suffix - name;
5182 int j;
5b4ee69b 5183
aeb5907d
JB
5184 is_new_style_renaming = 1;
5185 for (j = 0; j < nsyms; j += 1)
d12307c1
PMR
5186 if (i != j && syms[j].symbol != NULL
5187 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
aeb5907d
JB
5188 name_len) == 0
5189 && block == syms[j].block)
d12307c1 5190 syms[j].symbol = NULL;
aeb5907d
JB
5191 }
5192 }
5193 if (is_new_style_renaming)
5194 {
5195 int j, k;
5196
5197 for (j = k = 0; j < nsyms; j += 1)
d12307c1 5198 if (syms[j].symbol != NULL)
aeb5907d
JB
5199 {
5200 syms[k] = syms[j];
5201 k += 1;
5202 }
5203 return k;
5204 }
4c4b4cd2
PH
5205
5206 /* Extract the function name associated to CURRENT_BLOCK.
5207 Abort if unable to do so. */
76a01679 5208
4c4b4cd2
PH
5209 if (current_block == NULL)
5210 return nsyms;
76a01679 5211
7f0df278 5212 current_function = block_linkage_function (current_block);
4c4b4cd2
PH
5213 if (current_function == NULL)
5214 return nsyms;
5215
5216 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5217 if (current_function_name == NULL)
5218 return nsyms;
5219
5220 /* Check each of the symbols, and remove it from the list if it is
5221 a type corresponding to a renaming that is out of the scope of
5222 the current block. */
5223
5224 i = 0;
5225 while (i < nsyms)
5226 {
d12307c1 5227 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
aeb5907d 5228 == ADA_OBJECT_RENAMING
d12307c1 5229 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
4c4b4cd2
PH
5230 {
5231 int j;
5b4ee69b 5232
aeb5907d 5233 for (j = i + 1; j < nsyms; j += 1)
76a01679 5234 syms[j - 1] = syms[j];
4c4b4cd2
PH
5235 nsyms -= 1;
5236 }
5237 else
5238 i += 1;
5239 }
5240
5241 return nsyms;
5242}
5243
339c13b6
JB
5244/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5245 whose name and domain match NAME and DOMAIN respectively.
5246 If no match was found, then extend the search to "enclosing"
5247 routines (in other words, if we're inside a nested function,
5248 search the symbols defined inside the enclosing functions).
d0a8ab18
JB
5249 If WILD_MATCH_P is nonzero, perform the naming matching in
5250 "wild" mode (see function "wild_match" for more info).
339c13b6
JB
5251
5252 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5253
5254static void
5255ada_add_local_symbols (struct obstack *obstackp, const char *name,
f0c5f9b2 5256 const struct block *block, domain_enum domain,
d0a8ab18 5257 int wild_match_p)
339c13b6
JB
5258{
5259 int block_depth = 0;
5260
5261 while (block != NULL)
5262 {
5263 block_depth += 1;
d0a8ab18
JB
5264 ada_add_block_symbols (obstackp, block, name, domain, NULL,
5265 wild_match_p);
339c13b6
JB
5266
5267 /* If we found a non-function match, assume that's the one. */
5268 if (is_nonfunction (defns_collected (obstackp, 0),
5269 num_defns_collected (obstackp)))
5270 return;
5271
5272 block = BLOCK_SUPERBLOCK (block);
5273 }
5274
5275 /* If no luck so far, try to find NAME as a local symbol in some lexically
5276 enclosing subprogram. */
5277 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
d0a8ab18 5278 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
339c13b6
JB
5279}
5280
ccefe4c4 5281/* An object of this type is used as the user_data argument when
40658b94 5282 calling the map_matching_symbols method. */
ccefe4c4 5283
40658b94 5284struct match_data
ccefe4c4 5285{
40658b94 5286 struct objfile *objfile;
ccefe4c4 5287 struct obstack *obstackp;
40658b94
PH
5288 struct symbol *arg_sym;
5289 int found_sym;
ccefe4c4
TT
5290};
5291
40658b94
PH
5292/* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5293 to a list of symbols. DATA0 is a pointer to a struct match_data *
5294 containing the obstack that collects the symbol list, the file that SYM
5295 must come from, a flag indicating whether a non-argument symbol has
5296 been found in the current block, and the last argument symbol
5297 passed in SYM within the current block (if any). When SYM is null,
5298 marking the end of a block, the argument symbol is added if no
5299 other has been found. */
ccefe4c4 5300
40658b94
PH
5301static int
5302aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
ccefe4c4 5303{
40658b94
PH
5304 struct match_data *data = (struct match_data *) data0;
5305
5306 if (sym == NULL)
5307 {
5308 if (!data->found_sym && data->arg_sym != NULL)
5309 add_defn_to_vec (data->obstackp,
5310 fixup_symbol_section (data->arg_sym, data->objfile),
5311 block);
5312 data->found_sym = 0;
5313 data->arg_sym = NULL;
5314 }
5315 else
5316 {
5317 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5318 return 0;
5319 else if (SYMBOL_IS_ARGUMENT (sym))
5320 data->arg_sym = sym;
5321 else
5322 {
5323 data->found_sym = 1;
5324 add_defn_to_vec (data->obstackp,
5325 fixup_symbol_section (sym, data->objfile),
5326 block);
5327 }
5328 }
5329 return 0;
5330}
5331
db230ce3
JB
5332/* Implements compare_names, but only applying the comparision using
5333 the given CASING. */
5b4ee69b 5334
40658b94 5335static int
db230ce3
JB
5336compare_names_with_case (const char *string1, const char *string2,
5337 enum case_sensitivity casing)
40658b94
PH
5338{
5339 while (*string1 != '\0' && *string2 != '\0')
5340 {
db230ce3
JB
5341 char c1, c2;
5342
40658b94
PH
5343 if (isspace (*string1) || isspace (*string2))
5344 return strcmp_iw_ordered (string1, string2);
db230ce3
JB
5345
5346 if (casing == case_sensitive_off)
5347 {
5348 c1 = tolower (*string1);
5349 c2 = tolower (*string2);
5350 }
5351 else
5352 {
5353 c1 = *string1;
5354 c2 = *string2;
5355 }
5356 if (c1 != c2)
40658b94 5357 break;
db230ce3 5358
40658b94
PH
5359 string1 += 1;
5360 string2 += 1;
5361 }
db230ce3 5362
40658b94
PH
5363 switch (*string1)
5364 {
5365 case '(':
5366 return strcmp_iw_ordered (string1, string2);
5367 case '_':
5368 if (*string2 == '\0')
5369 {
052874e8 5370 if (is_name_suffix (string1))
40658b94
PH
5371 return 0;
5372 else
1a1d5513 5373 return 1;
40658b94 5374 }
dbb8534f 5375 /* FALLTHROUGH */
40658b94
PH
5376 default:
5377 if (*string2 == '(')
5378 return strcmp_iw_ordered (string1, string2);
5379 else
db230ce3
JB
5380 {
5381 if (casing == case_sensitive_off)
5382 return tolower (*string1) - tolower (*string2);
5383 else
5384 return *string1 - *string2;
5385 }
40658b94 5386 }
ccefe4c4
TT
5387}
5388
db230ce3
JB
5389/* Compare STRING1 to STRING2, with results as for strcmp.
5390 Compatible with strcmp_iw_ordered in that...
5391
5392 strcmp_iw_ordered (STRING1, STRING2) <= 0
5393
5394 ... implies...
5395
5396 compare_names (STRING1, STRING2) <= 0
5397
5398 (they may differ as to what symbols compare equal). */
5399
5400static int
5401compare_names (const char *string1, const char *string2)
5402{
5403 int result;
5404
5405 /* Similar to what strcmp_iw_ordered does, we need to perform
5406 a case-insensitive comparison first, and only resort to
5407 a second, case-sensitive, comparison if the first one was
5408 not sufficient to differentiate the two strings. */
5409
5410 result = compare_names_with_case (string1, string2, case_sensitive_off);
5411 if (result == 0)
5412 result = compare_names_with_case (string1, string2, case_sensitive_on);
5413
5414 return result;
5415}
5416
339c13b6
JB
5417/* Add to OBSTACKP all non-local symbols whose name and domain match
5418 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5419 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5420
5421static void
40658b94
PH
5422add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5423 domain_enum domain, int global,
5424 int is_wild_match)
339c13b6
JB
5425{
5426 struct objfile *objfile;
40658b94 5427 struct match_data data;
339c13b6 5428
6475f2fe 5429 memset (&data, 0, sizeof data);
ccefe4c4 5430 data.obstackp = obstackp;
339c13b6 5431
ccefe4c4 5432 ALL_OBJFILES (objfile)
40658b94
PH
5433 {
5434 data.objfile = objfile;
5435
5436 if (is_wild_match)
4186eb54
KS
5437 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5438 aux_add_nonlocal_symbols, &data,
5439 wild_match, NULL);
40658b94 5440 else
4186eb54
KS
5441 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5442 aux_add_nonlocal_symbols, &data,
5443 full_match, compare_names);
40658b94
PH
5444 }
5445
5446 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5447 {
5448 ALL_OBJFILES (objfile)
5449 {
5450 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5451 strcpy (name1, "_ada_");
5452 strcpy (name1 + sizeof ("_ada_") - 1, name);
5453 data.objfile = objfile;
ade7ed9e
DE
5454 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5455 global,
0963b4bd
MS
5456 aux_add_nonlocal_symbols,
5457 &data,
40658b94
PH
5458 full_match, compare_names);
5459 }
5460 }
339c13b6
JB
5461}
5462
4eeaa230
DE
5463/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5464 non-zero, enclosing scope and in global scopes, returning the number of
5465 matches.
9f88c959 5466 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4c4b4cd2 5467 indicating the symbols found and the blocks and symbol tables (if
4eeaa230
DE
5468 any) in which they were found. This vector is transient---good only to
5469 the next call of ada_lookup_symbol_list.
5470
5471 When full_search is non-zero, any non-function/non-enumeral
4c4b4cd2
PH
5472 symbol match within the nest of blocks whose innermost member is BLOCK0,
5473 is the one match returned (no other matches in that or
d9680e73 5474 enclosing blocks is returned). If there are any matches in or
4eeaa230
DE
5475 surrounding BLOCK0, then these alone are returned.
5476
9f88c959 5477 Names prefixed with "standard__" are handled specially: "standard__"
4c4b4cd2 5478 is first stripped off, and only static and global symbols are searched. */
14f9c5c9 5479
4eeaa230
DE
5480static int
5481ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
fe978cb0 5482 domain_enum domain,
d12307c1 5483 struct block_symbol **results,
4eeaa230 5484 int full_search)
14f9c5c9
AS
5485{
5486 struct symbol *sym;
f0c5f9b2 5487 const struct block *block;
4c4b4cd2 5488 const char *name;
82ccd55e 5489 const int wild_match_p = should_use_wild_match (name0);
b1eedac9 5490 int syms_from_global_search = 0;
4c4b4cd2 5491 int ndefns;
14f9c5c9 5492
4c4b4cd2
PH
5493 obstack_free (&symbol_list_obstack, NULL);
5494 obstack_init (&symbol_list_obstack);
14f9c5c9 5495
14f9c5c9
AS
5496 /* Search specified block and its superiors. */
5497
4c4b4cd2 5498 name = name0;
f0c5f9b2 5499 block = block0;
339c13b6
JB
5500
5501 /* Special case: If the user specifies a symbol name inside package
5502 Standard, do a non-wild matching of the symbol name without
5503 the "standard__" prefix. This was primarily introduced in order
5504 to allow the user to specifically access the standard exceptions
5505 using, for instance, Standard.Constraint_Error when Constraint_Error
5506 is ambiguous (due to the user defining its own Constraint_Error
5507 entity inside its program). */
61012eef 5508 if (startswith (name0, "standard__"))
4c4b4cd2 5509 {
4c4b4cd2
PH
5510 block = NULL;
5511 name = name0 + sizeof ("standard__") - 1;
5512 }
5513
339c13b6 5514 /* Check the non-global symbols. If we have ANY match, then we're done. */
14f9c5c9 5515
4eeaa230
DE
5516 if (block != NULL)
5517 {
5518 if (full_search)
5519 {
5520 ada_add_local_symbols (&symbol_list_obstack, name, block,
fe978cb0 5521 domain, wild_match_p);
4eeaa230
DE
5522 }
5523 else
5524 {
5525 /* In the !full_search case we're are being called by
5526 ada_iterate_over_symbols, and we don't want to search
5527 superblocks. */
5528 ada_add_block_symbols (&symbol_list_obstack, block, name,
fe978cb0 5529 domain, NULL, wild_match_p);
4eeaa230
DE
5530 }
5531 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5532 goto done;
5533 }
d2e4a39e 5534
339c13b6
JB
5535 /* No non-global symbols found. Check our cache to see if we have
5536 already performed this search before. If we have, then return
5537 the same result. */
5538
fe978cb0 5539 if (lookup_cached_symbol (name0, domain, &sym, &block))
4c4b4cd2
PH
5540 {
5541 if (sym != NULL)
2570f2b7 5542 add_defn_to_vec (&symbol_list_obstack, sym, block);
4c4b4cd2
PH
5543 goto done;
5544 }
14f9c5c9 5545
b1eedac9
JB
5546 syms_from_global_search = 1;
5547
339c13b6
JB
5548 /* Search symbols from all global blocks. */
5549
fe978cb0 5550 add_nonlocal_symbols (&symbol_list_obstack, name, domain, 1,
82ccd55e 5551 wild_match_p);
d2e4a39e 5552
4c4b4cd2 5553 /* Now add symbols from all per-file blocks if we've gotten no hits
339c13b6 5554 (not strictly correct, but perhaps better than an error). */
d2e4a39e 5555
4c4b4cd2 5556 if (num_defns_collected (&symbol_list_obstack) == 0)
fe978cb0 5557 add_nonlocal_symbols (&symbol_list_obstack, name, domain, 0,
82ccd55e 5558 wild_match_p);
14f9c5c9 5559
4c4b4cd2
PH
5560done:
5561 ndefns = num_defns_collected (&symbol_list_obstack);
5562 *results = defns_collected (&symbol_list_obstack, 1);
5563
5564 ndefns = remove_extra_symbols (*results, ndefns);
5565
b1eedac9 5566 if (ndefns == 0 && full_search && syms_from_global_search)
fe978cb0 5567 cache_symbol (name0, domain, NULL, NULL);
14f9c5c9 5568
b1eedac9 5569 if (ndefns == 1 && full_search && syms_from_global_search)
d12307c1 5570 cache_symbol (name0, domain, (*results)[0].symbol, (*results)[0].block);
14f9c5c9 5571
aeb5907d 5572 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
14f9c5c9 5573
14f9c5c9
AS
5574 return ndefns;
5575}
5576
4eeaa230
DE
5577/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5578 in global scopes, returning the number of matches, and setting *RESULTS
5579 to a vector of (SYM,BLOCK) tuples.
5580 See ada_lookup_symbol_list_worker for further details. */
5581
5582int
5583ada_lookup_symbol_list (const char *name0, const struct block *block0,
d12307c1 5584 domain_enum domain, struct block_symbol **results)
4eeaa230
DE
5585{
5586 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5587}
5588
5589/* Implementation of the la_iterate_over_symbols method. */
5590
5591static void
5592ada_iterate_over_symbols (const struct block *block,
5593 const char *name, domain_enum domain,
5594 symbol_found_callback_ftype *callback,
5595 void *data)
5596{
5597 int ndefs, i;
d12307c1 5598 struct block_symbol *results;
4eeaa230
DE
5599
5600 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5601 for (i = 0; i < ndefs; ++i)
5602 {
d12307c1 5603 if (! (*callback) (results[i].symbol, data))
4eeaa230
DE
5604 break;
5605 }
5606}
5607
f8eba3c6
TT
5608/* If NAME is the name of an entity, return a string that should
5609 be used to look that entity up in Ada units. This string should
5610 be deallocated after use using xfree.
5611
5612 NAME can have any form that the "break" or "print" commands might
5613 recognize. In other words, it does not have to be the "natural"
5614 name, or the "encoded" name. */
5615
5616char *
5617ada_name_for_lookup (const char *name)
5618{
5619 char *canon;
5620 int nlen = strlen (name);
5621
5622 if (name[0] == '<' && name[nlen - 1] == '>')
5623 {
5624 canon = xmalloc (nlen - 1);
5625 memcpy (canon, name + 1, nlen - 2);
5626 canon[nlen - 2] = '\0';
5627 }
5628 else
5629 canon = xstrdup (ada_encode (ada_fold_name (name)));
5630 return canon;
5631}
5632
4e5c77fe
JB
5633/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5634 to 1, but choosing the first symbol found if there are multiple
5635 choices.
5636
5e2336be
JB
5637 The result is stored in *INFO, which must be non-NULL.
5638 If no match is found, INFO->SYM is set to NULL. */
4e5c77fe
JB
5639
5640void
5641ada_lookup_encoded_symbol (const char *name, const struct block *block,
fe978cb0 5642 domain_enum domain,
d12307c1 5643 struct block_symbol *info)
14f9c5c9 5644{
d12307c1 5645 struct block_symbol *candidates;
14f9c5c9
AS
5646 int n_candidates;
5647
5e2336be 5648 gdb_assert (info != NULL);
d12307c1 5649 memset (info, 0, sizeof (struct block_symbol));
4e5c77fe 5650
fe978cb0 5651 n_candidates = ada_lookup_symbol_list (name, block, domain, &candidates);
14f9c5c9 5652 if (n_candidates == 0)
4e5c77fe 5653 return;
4c4b4cd2 5654
5e2336be 5655 *info = candidates[0];
d12307c1 5656 info->symbol = fixup_symbol_section (info->symbol, NULL);
4e5c77fe 5657}
aeb5907d
JB
5658
5659/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5660 scope and in global scopes, or NULL if none. NAME is folded and
5661 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
0963b4bd 5662 choosing the first symbol if there are multiple choices.
4e5c77fe
JB
5663 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5664
d12307c1 5665struct block_symbol
aeb5907d 5666ada_lookup_symbol (const char *name, const struct block *block0,
fe978cb0 5667 domain_enum domain, int *is_a_field_of_this)
aeb5907d 5668{
d12307c1 5669 struct block_symbol info;
4e5c77fe 5670
aeb5907d
JB
5671 if (is_a_field_of_this != NULL)
5672 *is_a_field_of_this = 0;
5673
4e5c77fe 5674 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
fe978cb0 5675 block0, domain, &info);
d12307c1 5676 return info;
4c4b4cd2 5677}
14f9c5c9 5678
d12307c1 5679static struct block_symbol
f606139a
DE
5680ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5681 const char *name,
76a01679 5682 const struct block *block,
21b556f4 5683 const domain_enum domain)
4c4b4cd2 5684{
d12307c1 5685 struct block_symbol sym;
04dccad0
JB
5686
5687 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
d12307c1 5688 if (sym.symbol != NULL)
04dccad0
JB
5689 return sym;
5690
5691 /* If we haven't found a match at this point, try the primitive
5692 types. In other languages, this search is performed before
5693 searching for global symbols in order to short-circuit that
5694 global-symbol search if it happens that the name corresponds
5695 to a primitive type. But we cannot do the same in Ada, because
5696 it is perfectly legitimate for a program to declare a type which
5697 has the same name as a standard type. If looking up a type in
5698 that situation, we have traditionally ignored the primitive type
5699 in favor of user-defined types. This is why, unlike most other
5700 languages, we search the primitive types this late and only after
5701 having searched the global symbols without success. */
5702
5703 if (domain == VAR_DOMAIN)
5704 {
5705 struct gdbarch *gdbarch;
5706
5707 if (block == NULL)
5708 gdbarch = target_gdbarch ();
5709 else
5710 gdbarch = block_gdbarch (block);
d12307c1
PMR
5711 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5712 if (sym.symbol != NULL)
04dccad0
JB
5713 return sym;
5714 }
5715
d12307c1 5716 return (struct block_symbol) {NULL, NULL};
14f9c5c9
AS
5717}
5718
5719
4c4b4cd2
PH
5720/* True iff STR is a possible encoded suffix of a normal Ada name
5721 that is to be ignored for matching purposes. Suffixes of parallel
5722 names (e.g., XVE) are not included here. Currently, the possible suffixes
5823c3ef 5723 are given by any of the regular expressions:
4c4b4cd2 5724
babe1480
JB
5725 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5726 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
9ac7f98e 5727 TKB [subprogram suffix for task bodies]
babe1480 5728 _E[0-9]+[bs]$ [protected object entry suffixes]
61ee279c 5729 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
babe1480
JB
5730
5731 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5732 match is performed. This sequence is used to differentiate homonyms,
5733 is an optional part of a valid name suffix. */
4c4b4cd2 5734
14f9c5c9 5735static int
d2e4a39e 5736is_name_suffix (const char *str)
14f9c5c9
AS
5737{
5738 int k;
4c4b4cd2
PH
5739 const char *matching;
5740 const int len = strlen (str);
5741
babe1480
JB
5742 /* Skip optional leading __[0-9]+. */
5743
4c4b4cd2
PH
5744 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5745 {
babe1480
JB
5746 str += 3;
5747 while (isdigit (str[0]))
5748 str += 1;
4c4b4cd2 5749 }
babe1480
JB
5750
5751 /* [.$][0-9]+ */
4c4b4cd2 5752
babe1480 5753 if (str[0] == '.' || str[0] == '$')
4c4b4cd2 5754 {
babe1480 5755 matching = str + 1;
4c4b4cd2
PH
5756 while (isdigit (matching[0]))
5757 matching += 1;
5758 if (matching[0] == '\0')
5759 return 1;
5760 }
5761
5762 /* ___[0-9]+ */
babe1480 5763
4c4b4cd2
PH
5764 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5765 {
5766 matching = str + 3;
5767 while (isdigit (matching[0]))
5768 matching += 1;
5769 if (matching[0] == '\0')
5770 return 1;
5771 }
5772
9ac7f98e
JB
5773 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5774
5775 if (strcmp (str, "TKB") == 0)
5776 return 1;
5777
529cad9c
PH
5778#if 0
5779 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
0963b4bd
MS
5780 with a N at the end. Unfortunately, the compiler uses the same
5781 convention for other internal types it creates. So treating
529cad9c 5782 all entity names that end with an "N" as a name suffix causes
0963b4bd
MS
5783 some regressions. For instance, consider the case of an enumerated
5784 type. To support the 'Image attribute, it creates an array whose
529cad9c
PH
5785 name ends with N.
5786 Having a single character like this as a suffix carrying some
0963b4bd 5787 information is a bit risky. Perhaps we should change the encoding
529cad9c
PH
5788 to be something like "_N" instead. In the meantime, do not do
5789 the following check. */
5790 /* Protected Object Subprograms */
5791 if (len == 1 && str [0] == 'N')
5792 return 1;
5793#endif
5794
5795 /* _E[0-9]+[bs]$ */
5796 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5797 {
5798 matching = str + 3;
5799 while (isdigit (matching[0]))
5800 matching += 1;
5801 if ((matching[0] == 'b' || matching[0] == 's')
5802 && matching [1] == '\0')
5803 return 1;
5804 }
5805
4c4b4cd2
PH
5806 /* ??? We should not modify STR directly, as we are doing below. This
5807 is fine in this case, but may become problematic later if we find
5808 that this alternative did not work, and want to try matching
5809 another one from the begining of STR. Since we modified it, we
5810 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
5811 if (str[0] == 'X')
5812 {
5813 str += 1;
d2e4a39e 5814 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
5815 {
5816 if (str[0] != 'n' && str[0] != 'b')
5817 return 0;
5818 str += 1;
5819 }
14f9c5c9 5820 }
babe1480 5821
14f9c5c9
AS
5822 if (str[0] == '\000')
5823 return 1;
babe1480 5824
d2e4a39e 5825 if (str[0] == '_')
14f9c5c9
AS
5826 {
5827 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 5828 return 0;
d2e4a39e 5829 if (str[2] == '_')
4c4b4cd2 5830 {
61ee279c
PH
5831 if (strcmp (str + 3, "JM") == 0)
5832 return 1;
5833 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5834 the LJM suffix in favor of the JM one. But we will
5835 still accept LJM as a valid suffix for a reasonable
5836 amount of time, just to allow ourselves to debug programs
5837 compiled using an older version of GNAT. */
4c4b4cd2
PH
5838 if (strcmp (str + 3, "LJM") == 0)
5839 return 1;
5840 if (str[3] != 'X')
5841 return 0;
1265e4aa
JB
5842 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5843 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
5844 return 1;
5845 if (str[4] == 'R' && str[5] != 'T')
5846 return 1;
5847 return 0;
5848 }
5849 if (!isdigit (str[2]))
5850 return 0;
5851 for (k = 3; str[k] != '\0'; k += 1)
5852 if (!isdigit (str[k]) && str[k] != '_')
5853 return 0;
14f9c5c9
AS
5854 return 1;
5855 }
4c4b4cd2 5856 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 5857 {
4c4b4cd2
PH
5858 for (k = 2; str[k] != '\0'; k += 1)
5859 if (!isdigit (str[k]) && str[k] != '_')
5860 return 0;
14f9c5c9
AS
5861 return 1;
5862 }
5863 return 0;
5864}
d2e4a39e 5865
aeb5907d
JB
5866/* Return non-zero if the string starting at NAME and ending before
5867 NAME_END contains no capital letters. */
529cad9c
PH
5868
5869static int
5870is_valid_name_for_wild_match (const char *name0)
5871{
5872 const char *decoded_name = ada_decode (name0);
5873 int i;
5874
5823c3ef
JB
5875 /* If the decoded name starts with an angle bracket, it means that
5876 NAME0 does not follow the GNAT encoding format. It should then
5877 not be allowed as a possible wild match. */
5878 if (decoded_name[0] == '<')
5879 return 0;
5880
529cad9c
PH
5881 for (i=0; decoded_name[i] != '\0'; i++)
5882 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5883 return 0;
5884
5885 return 1;
5886}
5887
73589123
PH
5888/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5889 that could start a simple name. Assumes that *NAMEP points into
5890 the string beginning at NAME0. */
4c4b4cd2 5891
14f9c5c9 5892static int
73589123 5893advance_wild_match (const char **namep, const char *name0, int target0)
14f9c5c9 5894{
73589123 5895 const char *name = *namep;
5b4ee69b 5896
5823c3ef 5897 while (1)
14f9c5c9 5898 {
aa27d0b3 5899 int t0, t1;
73589123
PH
5900
5901 t0 = *name;
5902 if (t0 == '_')
5903 {
5904 t1 = name[1];
5905 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5906 {
5907 name += 1;
61012eef 5908 if (name == name0 + 5 && startswith (name0, "_ada"))
73589123
PH
5909 break;
5910 else
5911 name += 1;
5912 }
aa27d0b3
JB
5913 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5914 || name[2] == target0))
73589123
PH
5915 {
5916 name += 2;
5917 break;
5918 }
5919 else
5920 return 0;
5921 }
5922 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5923 name += 1;
5924 else
5823c3ef 5925 return 0;
73589123
PH
5926 }
5927
5928 *namep = name;
5929 return 1;
5930}
5931
5932/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5933 informational suffixes of NAME (i.e., for which is_name_suffix is
5934 true). Assumes that PATN is a lower-cased Ada simple name. */
5935
5936static int
5937wild_match (const char *name, const char *patn)
5938{
22e048c9 5939 const char *p;
73589123
PH
5940 const char *name0 = name;
5941
5942 while (1)
5943 {
5944 const char *match = name;
5945
5946 if (*name == *patn)
5947 {
5948 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5949 if (*p != *name)
5950 break;
5951 if (*p == '\0' && is_name_suffix (name))
5952 return match != name0 && !is_valid_name_for_wild_match (name0);
5953
5954 if (name[-1] == '_')
5955 name -= 1;
5956 }
5957 if (!advance_wild_match (&name, name0, *patn))
5958 return 1;
96d887e8 5959 }
96d887e8
PH
5960}
5961
40658b94
PH
5962/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5963 informational suffix. */
5964
c4d840bd
PH
5965static int
5966full_match (const char *sym_name, const char *search_name)
5967{
40658b94 5968 return !match_name (sym_name, search_name, 0);
c4d840bd
PH
5969}
5970
5971
96d887e8
PH
5972/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5973 vector *defn_symbols, updating the list of symbols in OBSTACKP
0963b4bd 5974 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4eeaa230 5975 OBJFILE is the section containing BLOCK. */
96d887e8
PH
5976
5977static void
5978ada_add_block_symbols (struct obstack *obstackp,
f0c5f9b2 5979 const struct block *block, const char *name,
96d887e8 5980 domain_enum domain, struct objfile *objfile,
2570f2b7 5981 int wild)
96d887e8 5982{
8157b174 5983 struct block_iterator iter;
96d887e8
PH
5984 int name_len = strlen (name);
5985 /* A matching argument symbol, if any. */
5986 struct symbol *arg_sym;
5987 /* Set true when we find a matching non-argument symbol. */
5988 int found_sym;
5989 struct symbol *sym;
5990
5991 arg_sym = NULL;
5992 found_sym = 0;
5993 if (wild)
5994 {
8157b174
TT
5995 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5996 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
76a01679 5997 {
4186eb54
KS
5998 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5999 SYMBOL_DOMAIN (sym), domain)
73589123 6000 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
76a01679 6001 {
2a2d4dc3
AS
6002 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
6003 continue;
6004 else if (SYMBOL_IS_ARGUMENT (sym))
6005 arg_sym = sym;
6006 else
6007 {
76a01679
JB
6008 found_sym = 1;
6009 add_defn_to_vec (obstackp,
6010 fixup_symbol_section (sym, objfile),
2570f2b7 6011 block);
76a01679
JB
6012 }
6013 }
6014 }
96d887e8
PH
6015 }
6016 else
6017 {
8157b174
TT
6018 for (sym = block_iter_match_first (block, name, full_match, &iter);
6019 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
76a01679 6020 {
4186eb54
KS
6021 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6022 SYMBOL_DOMAIN (sym), domain))
76a01679 6023 {
c4d840bd
PH
6024 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6025 {
6026 if (SYMBOL_IS_ARGUMENT (sym))
6027 arg_sym = sym;
6028 else
2a2d4dc3 6029 {
c4d840bd
PH
6030 found_sym = 1;
6031 add_defn_to_vec (obstackp,
6032 fixup_symbol_section (sym, objfile),
6033 block);
2a2d4dc3 6034 }
c4d840bd 6035 }
76a01679
JB
6036 }
6037 }
96d887e8
PH
6038 }
6039
6040 if (!found_sym && arg_sym != NULL)
6041 {
76a01679
JB
6042 add_defn_to_vec (obstackp,
6043 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6044 block);
96d887e8
PH
6045 }
6046
6047 if (!wild)
6048 {
6049 arg_sym = NULL;
6050 found_sym = 0;
6051
6052 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 6053 {
4186eb54
KS
6054 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6055 SYMBOL_DOMAIN (sym), domain))
76a01679
JB
6056 {
6057 int cmp;
6058
6059 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6060 if (cmp == 0)
6061 {
61012eef 6062 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
76a01679
JB
6063 if (cmp == 0)
6064 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6065 name_len);
6066 }
6067
6068 if (cmp == 0
6069 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6070 {
2a2d4dc3
AS
6071 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6072 {
6073 if (SYMBOL_IS_ARGUMENT (sym))
6074 arg_sym = sym;
6075 else
6076 {
6077 found_sym = 1;
6078 add_defn_to_vec (obstackp,
6079 fixup_symbol_section (sym, objfile),
6080 block);
6081 }
6082 }
76a01679
JB
6083 }
6084 }
76a01679 6085 }
96d887e8
PH
6086
6087 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6088 They aren't parameters, right? */
6089 if (!found_sym && arg_sym != NULL)
6090 {
6091 add_defn_to_vec (obstackp,
76a01679 6092 fixup_symbol_section (arg_sym, objfile),
2570f2b7 6093 block);
96d887e8
PH
6094 }
6095 }
6096}
6097\f
41d27058
JB
6098
6099 /* Symbol Completion */
6100
6101/* If SYM_NAME is a completion candidate for TEXT, return this symbol
6102 name in a form that's appropriate for the completion. The result
6103 does not need to be deallocated, but is only good until the next call.
6104
6105 TEXT_LEN is equal to the length of TEXT.
e701b3c0 6106 Perform a wild match if WILD_MATCH_P is set.
6ea35997 6107 ENCODED_P should be set if TEXT represents the start of a symbol name
41d27058
JB
6108 in its encoded form. */
6109
6110static const char *
6111symbol_completion_match (const char *sym_name,
6112 const char *text, int text_len,
6ea35997 6113 int wild_match_p, int encoded_p)
41d27058 6114{
41d27058
JB
6115 const int verbatim_match = (text[0] == '<');
6116 int match = 0;
6117
6118 if (verbatim_match)
6119 {
6120 /* Strip the leading angle bracket. */
6121 text = text + 1;
6122 text_len--;
6123 }
6124
6125 /* First, test against the fully qualified name of the symbol. */
6126
6127 if (strncmp (sym_name, text, text_len) == 0)
6128 match = 1;
6129
6ea35997 6130 if (match && !encoded_p)
41d27058
JB
6131 {
6132 /* One needed check before declaring a positive match is to verify
6133 that iff we are doing a verbatim match, the decoded version
6134 of the symbol name starts with '<'. Otherwise, this symbol name
6135 is not a suitable completion. */
6136 const char *sym_name_copy = sym_name;
6137 int has_angle_bracket;
6138
6139 sym_name = ada_decode (sym_name);
6140 has_angle_bracket = (sym_name[0] == '<');
6141 match = (has_angle_bracket == verbatim_match);
6142 sym_name = sym_name_copy;
6143 }
6144
6145 if (match && !verbatim_match)
6146 {
6147 /* When doing non-verbatim match, another check that needs to
6148 be done is to verify that the potentially matching symbol name
6149 does not include capital letters, because the ada-mode would
6150 not be able to understand these symbol names without the
6151 angle bracket notation. */
6152 const char *tmp;
6153
6154 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6155 if (*tmp != '\0')
6156 match = 0;
6157 }
6158
6159 /* Second: Try wild matching... */
6160
e701b3c0 6161 if (!match && wild_match_p)
41d27058
JB
6162 {
6163 /* Since we are doing wild matching, this means that TEXT
6164 may represent an unqualified symbol name. We therefore must
6165 also compare TEXT against the unqualified name of the symbol. */
6166 sym_name = ada_unqualified_name (ada_decode (sym_name));
6167
6168 if (strncmp (sym_name, text, text_len) == 0)
6169 match = 1;
6170 }
6171
6172 /* Finally: If we found a mach, prepare the result to return. */
6173
6174 if (!match)
6175 return NULL;
6176
6177 if (verbatim_match)
6178 sym_name = add_angle_brackets (sym_name);
6179
6ea35997 6180 if (!encoded_p)
41d27058
JB
6181 sym_name = ada_decode (sym_name);
6182
6183 return sym_name;
6184}
6185
6186/* A companion function to ada_make_symbol_completion_list().
6187 Check if SYM_NAME represents a symbol which name would be suitable
6188 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6189 it is appended at the end of the given string vector SV.
6190
6191 ORIG_TEXT is the string original string from the user command
6192 that needs to be completed. WORD is the entire command on which
6193 completion should be performed. These two parameters are used to
6194 determine which part of the symbol name should be added to the
6195 completion vector.
c0af1706 6196 if WILD_MATCH_P is set, then wild matching is performed.
cb8e9b97 6197 ENCODED_P should be set if TEXT represents a symbol name in its
41d27058
JB
6198 encoded formed (in which case the completion should also be
6199 encoded). */
6200
6201static void
d6565258 6202symbol_completion_add (VEC(char_ptr) **sv,
41d27058
JB
6203 const char *sym_name,
6204 const char *text, int text_len,
6205 const char *orig_text, const char *word,
cb8e9b97 6206 int wild_match_p, int encoded_p)
41d27058
JB
6207{
6208 const char *match = symbol_completion_match (sym_name, text, text_len,
cb8e9b97 6209 wild_match_p, encoded_p);
41d27058
JB
6210 char *completion;
6211
6212 if (match == NULL)
6213 return;
6214
6215 /* We found a match, so add the appropriate completion to the given
6216 string vector. */
6217
6218 if (word == orig_text)
6219 {
6220 completion = xmalloc (strlen (match) + 5);
6221 strcpy (completion, match);
6222 }
6223 else if (word > orig_text)
6224 {
6225 /* Return some portion of sym_name. */
6226 completion = xmalloc (strlen (match) + 5);
6227 strcpy (completion, match + (word - orig_text));
6228 }
6229 else
6230 {
6231 /* Return some of ORIG_TEXT plus sym_name. */
6232 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
6233 strncpy (completion, word, orig_text - word);
6234 completion[orig_text - word] = '\0';
6235 strcat (completion, match);
6236 }
6237
d6565258 6238 VEC_safe_push (char_ptr, *sv, completion);
41d27058
JB
6239}
6240
ccefe4c4 6241/* An object of this type is passed as the user_data argument to the
bb4142cf 6242 expand_symtabs_matching method. */
ccefe4c4
TT
6243struct add_partial_datum
6244{
6245 VEC(char_ptr) **completions;
6f937416 6246 const char *text;
ccefe4c4 6247 int text_len;
6f937416
PA
6248 const char *text0;
6249 const char *word;
ccefe4c4
TT
6250 int wild_match;
6251 int encoded;
6252};
6253
bb4142cf
DE
6254/* A callback for expand_symtabs_matching. */
6255
7b08b9eb 6256static int
bb4142cf 6257ada_complete_symbol_matcher (const char *name, void *user_data)
ccefe4c4
TT
6258{
6259 struct add_partial_datum *data = user_data;
7b08b9eb
JK
6260
6261 return symbol_completion_match (name, data->text, data->text_len,
6262 data->wild_match, data->encoded) != NULL;
ccefe4c4
TT
6263}
6264
49c4e619
TT
6265/* Return a list of possible symbol names completing TEXT0. WORD is
6266 the entire command on which completion is made. */
41d27058 6267
49c4e619 6268static VEC (char_ptr) *
6f937416
PA
6269ada_make_symbol_completion_list (const char *text0, const char *word,
6270 enum type_code code)
41d27058
JB
6271{
6272 char *text;
6273 int text_len;
b1ed564a
JB
6274 int wild_match_p;
6275 int encoded_p;
2ba95b9b 6276 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
41d27058 6277 struct symbol *sym;
43f3e411 6278 struct compunit_symtab *s;
41d27058
JB
6279 struct minimal_symbol *msymbol;
6280 struct objfile *objfile;
3977b71f 6281 const struct block *b, *surrounding_static_block = 0;
41d27058 6282 int i;
8157b174 6283 struct block_iterator iter;
b8fea896 6284 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
41d27058 6285
2f68a895
TT
6286 gdb_assert (code == TYPE_CODE_UNDEF);
6287
41d27058
JB
6288 if (text0[0] == '<')
6289 {
6290 text = xstrdup (text0);
6291 make_cleanup (xfree, text);
6292 text_len = strlen (text);
b1ed564a
JB
6293 wild_match_p = 0;
6294 encoded_p = 1;
41d27058
JB
6295 }
6296 else
6297 {
6298 text = xstrdup (ada_encode (text0));
6299 make_cleanup (xfree, text);
6300 text_len = strlen (text);
6301 for (i = 0; i < text_len; i++)
6302 text[i] = tolower (text[i]);
6303
b1ed564a 6304 encoded_p = (strstr (text0, "__") != NULL);
41d27058
JB
6305 /* If the name contains a ".", then the user is entering a fully
6306 qualified entity name, and the match must not be done in wild
6307 mode. Similarly, if the user wants to complete what looks like
6308 an encoded name, the match must not be done in wild mode. */
b1ed564a 6309 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
41d27058
JB
6310 }
6311
6312 /* First, look at the partial symtab symbols. */
41d27058 6313 {
ccefe4c4
TT
6314 struct add_partial_datum data;
6315
6316 data.completions = &completions;
6317 data.text = text;
6318 data.text_len = text_len;
6319 data.text0 = text0;
6320 data.word = word;
b1ed564a
JB
6321 data.wild_match = wild_match_p;
6322 data.encoded = encoded_p;
276d885b
GB
6323 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, NULL,
6324 ALL_DOMAIN, &data);
41d27058
JB
6325 }
6326
6327 /* At this point scan through the misc symbol vectors and add each
6328 symbol you find to the list. Eventually we want to ignore
6329 anything that isn't a text symbol (everything else will be
6330 handled by the psymtab code above). */
6331
6332 ALL_MSYMBOLS (objfile, msymbol)
6333 {
6334 QUIT;
efd66ac6 6335 symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol),
b1ed564a
JB
6336 text, text_len, text0, word, wild_match_p,
6337 encoded_p);
41d27058
JB
6338 }
6339
6340 /* Search upwards from currently selected frame (so that we can
6341 complete on local vars. */
6342
6343 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6344 {
6345 if (!BLOCK_SUPERBLOCK (b))
6346 surrounding_static_block = b; /* For elmin of dups */
6347
6348 ALL_BLOCK_SYMBOLS (b, iter, sym)
6349 {
d6565258 6350 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6351 text, text_len, text0, word,
b1ed564a 6352 wild_match_p, encoded_p);
41d27058
JB
6353 }
6354 }
6355
6356 /* Go through the symtabs and check the externs and statics for
43f3e411 6357 symbols which match. */
41d27058 6358
43f3e411 6359 ALL_COMPUNITS (objfile, s)
41d27058
JB
6360 {
6361 QUIT;
43f3e411 6362 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
41d27058
JB
6363 ALL_BLOCK_SYMBOLS (b, iter, sym)
6364 {
d6565258 6365 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6366 text, text_len, text0, word,
b1ed564a 6367 wild_match_p, encoded_p);
41d27058
JB
6368 }
6369 }
6370
43f3e411 6371 ALL_COMPUNITS (objfile, s)
41d27058
JB
6372 {
6373 QUIT;
43f3e411 6374 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
41d27058
JB
6375 /* Don't do this block twice. */
6376 if (b == surrounding_static_block)
6377 continue;
6378 ALL_BLOCK_SYMBOLS (b, iter, sym)
6379 {
d6565258 6380 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
41d27058 6381 text, text_len, text0, word,
b1ed564a 6382 wild_match_p, encoded_p);
41d27058
JB
6383 }
6384 }
6385
b8fea896 6386 do_cleanups (old_chain);
49c4e619 6387 return completions;
41d27058
JB
6388}
6389
963a6417 6390 /* Field Access */
96d887e8 6391
73fb9985
JB
6392/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6393 for tagged types. */
6394
6395static int
6396ada_is_dispatch_table_ptr_type (struct type *type)
6397{
0d5cff50 6398 const char *name;
73fb9985
JB
6399
6400 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6401 return 0;
6402
6403 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6404 if (name == NULL)
6405 return 0;
6406
6407 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6408}
6409
ac4a2da4
JG
6410/* Return non-zero if TYPE is an interface tag. */
6411
6412static int
6413ada_is_interface_tag (struct type *type)
6414{
6415 const char *name = TYPE_NAME (type);
6416
6417 if (name == NULL)
6418 return 0;
6419
6420 return (strcmp (name, "ada__tags__interface_tag") == 0);
6421}
6422
963a6417
PH
6423/* True if field number FIELD_NUM in struct or union type TYPE is supposed
6424 to be invisible to users. */
96d887e8 6425
963a6417
PH
6426int
6427ada_is_ignored_field (struct type *type, int field_num)
96d887e8 6428{
963a6417
PH
6429 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6430 return 1;
ffde82bf 6431
73fb9985
JB
6432 /* Check the name of that field. */
6433 {
6434 const char *name = TYPE_FIELD_NAME (type, field_num);
6435
6436 /* Anonymous field names should not be printed.
6437 brobecker/2007-02-20: I don't think this can actually happen
6438 but we don't want to print the value of annonymous fields anyway. */
6439 if (name == NULL)
6440 return 1;
6441
ffde82bf
JB
6442 /* Normally, fields whose name start with an underscore ("_")
6443 are fields that have been internally generated by the compiler,
6444 and thus should not be printed. The "_parent" field is special,
6445 however: This is a field internally generated by the compiler
6446 for tagged types, and it contains the components inherited from
6447 the parent type. This field should not be printed as is, but
6448 should not be ignored either. */
61012eef 6449 if (name[0] == '_' && !startswith (name, "_parent"))
73fb9985
JB
6450 return 1;
6451 }
6452
ac4a2da4
JG
6453 /* If this is the dispatch table of a tagged type or an interface tag,
6454 then ignore. */
73fb9985 6455 if (ada_is_tagged_type (type, 1)
ac4a2da4
JG
6456 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6457 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
73fb9985
JB
6458 return 1;
6459
6460 /* Not a special field, so it should not be ignored. */
6461 return 0;
963a6417 6462}
96d887e8 6463
963a6417 6464/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
0963b4bd 6465 pointer or reference type whose ultimate target has a tag field. */
96d887e8 6466
963a6417
PH
6467int
6468ada_is_tagged_type (struct type *type, int refok)
6469{
6470 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6471}
96d887e8 6472
963a6417 6473/* True iff TYPE represents the type of X'Tag */
96d887e8 6474
963a6417
PH
6475int
6476ada_is_tag_type (struct type *type)
6477{
460efde1
JB
6478 type = ada_check_typedef (type);
6479
963a6417
PH
6480 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6481 return 0;
6482 else
96d887e8 6483 {
963a6417 6484 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5b4ee69b 6485
963a6417
PH
6486 return (name != NULL
6487 && strcmp (name, "ada__tags__dispatch_table") == 0);
96d887e8 6488 }
96d887e8
PH
6489}
6490
963a6417 6491/* The type of the tag on VAL. */
76a01679 6492
963a6417
PH
6493struct type *
6494ada_tag_type (struct value *val)
96d887e8 6495{
df407dfe 6496 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
963a6417 6497}
96d887e8 6498
b50d69b5
JG
6499/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6500 retired at Ada 05). */
6501
6502static int
6503is_ada95_tag (struct value *tag)
6504{
6505 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6506}
6507
963a6417 6508/* The value of the tag on VAL. */
96d887e8 6509
963a6417
PH
6510struct value *
6511ada_value_tag (struct value *val)
6512{
03ee6b2e 6513 return ada_value_struct_elt (val, "_tag", 0);
96d887e8
PH
6514}
6515
963a6417
PH
6516/* The value of the tag on the object of type TYPE whose contents are
6517 saved at VALADDR, if it is non-null, or is at memory address
0963b4bd 6518 ADDRESS. */
96d887e8 6519
963a6417 6520static struct value *
10a2c479 6521value_tag_from_contents_and_address (struct type *type,
fc1a4b47 6522 const gdb_byte *valaddr,
963a6417 6523 CORE_ADDR address)
96d887e8 6524{
b5385fc0 6525 int tag_byte_offset;
963a6417 6526 struct type *tag_type;
5b4ee69b 6527
963a6417 6528 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
52ce6436 6529 NULL, NULL, NULL))
96d887e8 6530 {
fc1a4b47 6531 const gdb_byte *valaddr1 = ((valaddr == NULL)
10a2c479
AC
6532 ? NULL
6533 : valaddr + tag_byte_offset);
963a6417 6534 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
96d887e8 6535
963a6417 6536 return value_from_contents_and_address (tag_type, valaddr1, address1);
96d887e8 6537 }
963a6417
PH
6538 return NULL;
6539}
96d887e8 6540
963a6417
PH
6541static struct type *
6542type_from_tag (struct value *tag)
6543{
6544 const char *type_name = ada_tag_name (tag);
5b4ee69b 6545
963a6417
PH
6546 if (type_name != NULL)
6547 return ada_find_any_type (ada_encode (type_name));
6548 return NULL;
6549}
96d887e8 6550
b50d69b5
JG
6551/* Given a value OBJ of a tagged type, return a value of this
6552 type at the base address of the object. The base address, as
6553 defined in Ada.Tags, it is the address of the primary tag of
6554 the object, and therefore where the field values of its full
6555 view can be fetched. */
6556
6557struct value *
6558ada_tag_value_at_base_address (struct value *obj)
6559{
b50d69b5
JG
6560 struct value *val;
6561 LONGEST offset_to_top = 0;
6562 struct type *ptr_type, *obj_type;
6563 struct value *tag;
6564 CORE_ADDR base_address;
6565
6566 obj_type = value_type (obj);
6567
6568 /* It is the responsability of the caller to deref pointers. */
6569
6570 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6571 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6572 return obj;
6573
6574 tag = ada_value_tag (obj);
6575 if (!tag)
6576 return obj;
6577
6578 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6579
6580 if (is_ada95_tag (tag))
6581 return obj;
6582
6583 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6584 ptr_type = lookup_pointer_type (ptr_type);
6585 val = value_cast (ptr_type, tag);
6586 if (!val)
6587 return obj;
6588
6589 /* It is perfectly possible that an exception be raised while
6590 trying to determine the base address, just like for the tag;
6591 see ada_tag_name for more details. We do not print the error
6592 message for the same reason. */
6593
492d29ea 6594 TRY
b50d69b5
JG
6595 {
6596 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6597 }
6598
492d29ea
PA
6599 CATCH (e, RETURN_MASK_ERROR)
6600 {
6601 return obj;
6602 }
6603 END_CATCH
b50d69b5
JG
6604
6605 /* If offset is null, nothing to do. */
6606
6607 if (offset_to_top == 0)
6608 return obj;
6609
6610 /* -1 is a special case in Ada.Tags; however, what should be done
6611 is not quite clear from the documentation. So do nothing for
6612 now. */
6613
6614 if (offset_to_top == -1)
6615 return obj;
6616
6617 base_address = value_address (obj) - offset_to_top;
6618 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6619
6620 /* Make sure that we have a proper tag at the new address.
6621 Otherwise, offset_to_top is bogus (which can happen when
6622 the object is not initialized yet). */
6623
6624 if (!tag)
6625 return obj;
6626
6627 obj_type = type_from_tag (tag);
6628
6629 if (!obj_type)
6630 return obj;
6631
6632 return value_from_contents_and_address (obj_type, NULL, base_address);
6633}
6634
1b611343
JB
6635/* Return the "ada__tags__type_specific_data" type. */
6636
6637static struct type *
6638ada_get_tsd_type (struct inferior *inf)
963a6417 6639{
1b611343 6640 struct ada_inferior_data *data = get_ada_inferior_data (inf);
4c4b4cd2 6641
1b611343
JB
6642 if (data->tsd_type == 0)
6643 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6644 return data->tsd_type;
6645}
529cad9c 6646
1b611343
JB
6647/* Return the TSD (type-specific data) associated to the given TAG.
6648 TAG is assumed to be the tag of a tagged-type entity.
529cad9c 6649
1b611343 6650 May return NULL if we are unable to get the TSD. */
4c4b4cd2 6651
1b611343
JB
6652static struct value *
6653ada_get_tsd_from_tag (struct value *tag)
4c4b4cd2 6654{
4c4b4cd2 6655 struct value *val;
1b611343 6656 struct type *type;
5b4ee69b 6657
1b611343
JB
6658 /* First option: The TSD is simply stored as a field of our TAG.
6659 Only older versions of GNAT would use this format, but we have
6660 to test it first, because there are no visible markers for
6661 the current approach except the absence of that field. */
529cad9c 6662
1b611343
JB
6663 val = ada_value_struct_elt (tag, "tsd", 1);
6664 if (val)
6665 return val;
e802dbe0 6666
1b611343
JB
6667 /* Try the second representation for the dispatch table (in which
6668 there is no explicit 'tsd' field in the referent of the tag pointer,
6669 and instead the tsd pointer is stored just before the dispatch
6670 table. */
e802dbe0 6671
1b611343
JB
6672 type = ada_get_tsd_type (current_inferior());
6673 if (type == NULL)
6674 return NULL;
6675 type = lookup_pointer_type (lookup_pointer_type (type));
6676 val = value_cast (type, tag);
6677 if (val == NULL)
6678 return NULL;
6679 return value_ind (value_ptradd (val, -1));
e802dbe0
JB
6680}
6681
1b611343
JB
6682/* Given the TSD of a tag (type-specific data), return a string
6683 containing the name of the associated type.
6684
6685 The returned value is good until the next call. May return NULL
6686 if we are unable to determine the tag name. */
6687
6688static char *
6689ada_tag_name_from_tsd (struct value *tsd)
529cad9c 6690{
529cad9c
PH
6691 static char name[1024];
6692 char *p;
1b611343 6693 struct value *val;
529cad9c 6694
1b611343 6695 val = ada_value_struct_elt (tsd, "expanded_name", 1);
4c4b4cd2 6696 if (val == NULL)
1b611343 6697 return NULL;
4c4b4cd2
PH
6698 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6699 for (p = name; *p != '\0'; p += 1)
6700 if (isalpha (*p))
6701 *p = tolower (*p);
1b611343 6702 return name;
4c4b4cd2
PH
6703}
6704
6705/* The type name of the dynamic type denoted by the 'tag value TAG, as
1b611343
JB
6706 a C string.
6707
6708 Return NULL if the TAG is not an Ada tag, or if we were unable to
6709 determine the name of that tag. The result is good until the next
6710 call. */
4c4b4cd2
PH
6711
6712const char *
6713ada_tag_name (struct value *tag)
6714{
1b611343 6715 char *name = NULL;
5b4ee69b 6716
df407dfe 6717 if (!ada_is_tag_type (value_type (tag)))
4c4b4cd2 6718 return NULL;
1b611343
JB
6719
6720 /* It is perfectly possible that an exception be raised while trying
6721 to determine the TAG's name, even under normal circumstances:
6722 The associated variable may be uninitialized or corrupted, for
6723 instance. We do not let any exception propagate past this point.
6724 instead we return NULL.
6725
6726 We also do not print the error message either (which often is very
6727 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6728 the caller print a more meaningful message if necessary. */
492d29ea 6729 TRY
1b611343
JB
6730 {
6731 struct value *tsd = ada_get_tsd_from_tag (tag);
6732
6733 if (tsd != NULL)
6734 name = ada_tag_name_from_tsd (tsd);
6735 }
492d29ea
PA
6736 CATCH (e, RETURN_MASK_ERROR)
6737 {
6738 }
6739 END_CATCH
1b611343
JB
6740
6741 return name;
4c4b4cd2
PH
6742}
6743
6744/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6745
d2e4a39e 6746struct type *
ebf56fd3 6747ada_parent_type (struct type *type)
14f9c5c9
AS
6748{
6749 int i;
6750
61ee279c 6751 type = ada_check_typedef (type);
14f9c5c9
AS
6752
6753 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6754 return NULL;
6755
6756 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6757 if (ada_is_parent_field (type, i))
0c1f74cf
JB
6758 {
6759 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6760
6761 /* If the _parent field is a pointer, then dereference it. */
6762 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6763 parent_type = TYPE_TARGET_TYPE (parent_type);
6764 /* If there is a parallel XVS type, get the actual base type. */
6765 parent_type = ada_get_base_type (parent_type);
6766
6767 return ada_check_typedef (parent_type);
6768 }
14f9c5c9
AS
6769
6770 return NULL;
6771}
6772
4c4b4cd2
PH
6773/* True iff field number FIELD_NUM of structure type TYPE contains the
6774 parent-type (inherited) fields of a derived type. Assumes TYPE is
6775 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6776
6777int
ebf56fd3 6778ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6779{
61ee279c 6780 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5b4ee69b 6781
4c4b4cd2 6782 return (name != NULL
61012eef
GB
6783 && (startswith (name, "PARENT")
6784 || startswith (name, "_parent")));
14f9c5c9
AS
6785}
6786
4c4b4cd2 6787/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6788 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6789 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6790 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6791 structures. */
14f9c5c9
AS
6792
6793int
ebf56fd3 6794ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6795{
d2e4a39e 6796 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6797
d2e4a39e 6798 return (name != NULL
61012eef 6799 && (startswith (name, "PARENT")
4c4b4cd2 6800 || strcmp (name, "REP") == 0
61012eef 6801 || startswith (name, "_parent")
4c4b4cd2 6802 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6803}
6804
4c4b4cd2
PH
6805/* True iff field number FIELD_NUM of structure or union type TYPE
6806 is a variant wrapper. Assumes TYPE is a structure type with at least
6807 FIELD_NUM+1 fields. */
14f9c5c9
AS
6808
6809int
ebf56fd3 6810ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6811{
d2e4a39e 6812 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5b4ee69b 6813
14f9c5c9 6814 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2 6815 || (is_dynamic_field (type, field_num)
c3e5cd34
PH
6816 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6817 == TYPE_CODE_UNION)));
14f9c5c9
AS
6818}
6819
6820/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6821 whose discriminants are contained in the record type OUTER_TYPE,
7c964f07
UW
6822 returns the type of the controlling discriminant for the variant.
6823 May return NULL if the type could not be found. */
14f9c5c9 6824
d2e4a39e 6825struct type *
ebf56fd3 6826ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6827{
d2e4a39e 6828 char *name = ada_variant_discrim_name (var_type);
5b4ee69b 6829
7c964f07 6830 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6831}
6832
4c4b4cd2 6833/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6834 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6835 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6836
6837int
ebf56fd3 6838ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6839{
d2e4a39e 6840 const char *name = TYPE_FIELD_NAME (type, field_num);
5b4ee69b 6841
14f9c5c9
AS
6842 return (name != NULL && name[0] == 'O');
6843}
6844
6845/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6846 returns the name of the discriminant controlling the variant.
6847 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6848
d2e4a39e 6849char *
ebf56fd3 6850ada_variant_discrim_name (struct type *type0)
14f9c5c9 6851{
d2e4a39e 6852 static char *result = NULL;
14f9c5c9 6853 static size_t result_len = 0;
d2e4a39e
AS
6854 struct type *type;
6855 const char *name;
6856 const char *discrim_end;
6857 const char *discrim_start;
14f9c5c9
AS
6858
6859 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6860 type = TYPE_TARGET_TYPE (type0);
6861 else
6862 type = type0;
6863
6864 name = ada_type_name (type);
6865
6866 if (name == NULL || name[0] == '\000')
6867 return "";
6868
6869 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6870 discrim_end -= 1)
6871 {
61012eef 6872 if (startswith (discrim_end, "___XVN"))
4c4b4cd2 6873 break;
14f9c5c9
AS
6874 }
6875 if (discrim_end == name)
6876 return "";
6877
d2e4a39e 6878 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6879 discrim_start -= 1)
6880 {
d2e4a39e 6881 if (discrim_start == name + 1)
4c4b4cd2 6882 return "";
76a01679 6883 if ((discrim_start > name + 3
61012eef 6884 && startswith (discrim_start - 3, "___"))
4c4b4cd2
PH
6885 || discrim_start[-1] == '.')
6886 break;
14f9c5c9
AS
6887 }
6888
6889 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6890 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6891 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6892 return result;
6893}
6894
4c4b4cd2
PH
6895/* Scan STR for a subtype-encoded number, beginning at position K.
6896 Put the position of the character just past the number scanned in
6897 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6898 Return 1 if there was a valid number at the given position, and 0
6899 otherwise. A "subtype-encoded" number consists of the absolute value
6900 in decimal, followed by the letter 'm' to indicate a negative number.
6901 Assumes 0m does not occur. */
14f9c5c9
AS
6902
6903int
d2e4a39e 6904ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6905{
6906 ULONGEST RU;
6907
d2e4a39e 6908 if (!isdigit (str[k]))
14f9c5c9
AS
6909 return 0;
6910
4c4b4cd2 6911 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6912 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6913 LONGEST. */
14f9c5c9
AS
6914 RU = 0;
6915 while (isdigit (str[k]))
6916 {
d2e4a39e 6917 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6918 k += 1;
6919 }
6920
d2e4a39e 6921 if (str[k] == 'm')
14f9c5c9
AS
6922 {
6923 if (R != NULL)
4c4b4cd2 6924 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6925 k += 1;
6926 }
6927 else if (R != NULL)
6928 *R = (LONGEST) RU;
6929
4c4b4cd2 6930 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6931 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6932 number representable as a LONGEST (although either would probably work
6933 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6934 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6935
6936 if (new_k != NULL)
6937 *new_k = k;
6938 return 1;
6939}
6940
4c4b4cd2
PH
6941/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6942 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6943 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6944
d2e4a39e 6945int
ebf56fd3 6946ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6947{
d2e4a39e 6948 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6949 int p;
6950
6951 p = 0;
6952 while (1)
6953 {
d2e4a39e 6954 switch (name[p])
4c4b4cd2
PH
6955 {
6956 case '\0':
6957 return 0;
6958 case 'S':
6959 {
6960 LONGEST W;
5b4ee69b 6961
4c4b4cd2
PH
6962 if (!ada_scan_number (name, p + 1, &W, &p))
6963 return 0;
6964 if (val == W)
6965 return 1;
6966 break;
6967 }
6968 case 'R':
6969 {
6970 LONGEST L, U;
5b4ee69b 6971
4c4b4cd2
PH
6972 if (!ada_scan_number (name, p + 1, &L, &p)
6973 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6974 return 0;
6975 if (val >= L && val <= U)
6976 return 1;
6977 break;
6978 }
6979 case 'O':
6980 return 1;
6981 default:
6982 return 0;
6983 }
6984 }
6985}
6986
0963b4bd 6987/* FIXME: Lots of redundancy below. Try to consolidate. */
4c4b4cd2
PH
6988
6989/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6990 ARG_TYPE, extract and return the value of one of its (non-static)
6991 fields. FIELDNO says which field. Differs from value_primitive_field
6992 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6993
4c4b4cd2 6994static struct value *
d2e4a39e 6995ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6996 struct type *arg_type)
14f9c5c9 6997{
14f9c5c9
AS
6998 struct type *type;
6999
61ee279c 7000 arg_type = ada_check_typedef (arg_type);
14f9c5c9
AS
7001 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7002
4c4b4cd2 7003 /* Handle packed fields. */
14f9c5c9
AS
7004
7005 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7006 {
7007 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7008 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 7009
0fd88904 7010 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
4c4b4cd2
PH
7011 offset + bit_pos / 8,
7012 bit_pos % 8, bit_size, type);
14f9c5c9
AS
7013 }
7014 else
7015 return value_primitive_field (arg1, offset, fieldno, arg_type);
7016}
7017
52ce6436
PH
7018/* Find field with name NAME in object of type TYPE. If found,
7019 set the following for each argument that is non-null:
7020 - *FIELD_TYPE_P to the field's type;
7021 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7022 an object of that type;
7023 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7024 - *BIT_SIZE_P to its size in bits if the field is packed, and
7025 0 otherwise;
7026 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7027 fields up to but not including the desired field, or by the total
7028 number of fields if not found. A NULL value of NAME never
7029 matches; the function just counts visible fields in this case.
7030
0963b4bd 7031 Returns 1 if found, 0 otherwise. */
52ce6436 7032
4c4b4cd2 7033static int
0d5cff50 7034find_struct_field (const char *name, struct type *type, int offset,
76a01679 7035 struct type **field_type_p,
52ce6436
PH
7036 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7037 int *index_p)
4c4b4cd2
PH
7038{
7039 int i;
7040
61ee279c 7041 type = ada_check_typedef (type);
76a01679 7042
52ce6436
PH
7043 if (field_type_p != NULL)
7044 *field_type_p = NULL;
7045 if (byte_offset_p != NULL)
d5d6fca5 7046 *byte_offset_p = 0;
52ce6436
PH
7047 if (bit_offset_p != NULL)
7048 *bit_offset_p = 0;
7049 if (bit_size_p != NULL)
7050 *bit_size_p = 0;
7051
7052 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
7053 {
7054 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7055 int fld_offset = offset + bit_pos / 8;
0d5cff50 7056 const char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 7057
4c4b4cd2
PH
7058 if (t_field_name == NULL)
7059 continue;
7060
52ce6436 7061 else if (name != NULL && field_name_match (t_field_name, name))
76a01679
JB
7062 {
7063 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5b4ee69b 7064
52ce6436
PH
7065 if (field_type_p != NULL)
7066 *field_type_p = TYPE_FIELD_TYPE (type, i);
7067 if (byte_offset_p != NULL)
7068 *byte_offset_p = fld_offset;
7069 if (bit_offset_p != NULL)
7070 *bit_offset_p = bit_pos % 8;
7071 if (bit_size_p != NULL)
7072 *bit_size_p = bit_size;
76a01679
JB
7073 return 1;
7074 }
4c4b4cd2
PH
7075 else if (ada_is_wrapper_field (type, i))
7076 {
52ce6436
PH
7077 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7078 field_type_p, byte_offset_p, bit_offset_p,
7079 bit_size_p, index_p))
76a01679
JB
7080 return 1;
7081 }
4c4b4cd2
PH
7082 else if (ada_is_variant_part (type, i))
7083 {
52ce6436
PH
7084 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7085 fixed type?? */
4c4b4cd2 7086 int j;
52ce6436
PH
7087 struct type *field_type
7088 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
4c4b4cd2 7089
52ce6436 7090 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7091 {
76a01679
JB
7092 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7093 fld_offset
7094 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7095 field_type_p, byte_offset_p,
52ce6436 7096 bit_offset_p, bit_size_p, index_p))
76a01679 7097 return 1;
4c4b4cd2
PH
7098 }
7099 }
52ce6436
PH
7100 else if (index_p != NULL)
7101 *index_p += 1;
4c4b4cd2
PH
7102 }
7103 return 0;
7104}
7105
0963b4bd 7106/* Number of user-visible fields in record type TYPE. */
4c4b4cd2 7107
52ce6436
PH
7108static int
7109num_visible_fields (struct type *type)
7110{
7111 int n;
5b4ee69b 7112
52ce6436
PH
7113 n = 0;
7114 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7115 return n;
7116}
14f9c5c9 7117
4c4b4cd2 7118/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
7119 and search in it assuming it has (class) type TYPE.
7120 If found, return value, else return NULL.
7121
4c4b4cd2 7122 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 7123
4c4b4cd2 7124static struct value *
d2e4a39e 7125ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 7126 struct type *type)
14f9c5c9
AS
7127{
7128 int i;
14f9c5c9 7129
5b4ee69b 7130 type = ada_check_typedef (type);
52ce6436 7131 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
14f9c5c9 7132 {
0d5cff50 7133 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7134
7135 if (t_field_name == NULL)
4c4b4cd2 7136 continue;
14f9c5c9
AS
7137
7138 else if (field_name_match (t_field_name, name))
4c4b4cd2 7139 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
7140
7141 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 7142 {
0963b4bd 7143 struct value *v = /* Do not let indent join lines here. */
06d5cf63
JB
7144 ada_search_struct_field (name, arg,
7145 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7146 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7147
4c4b4cd2
PH
7148 if (v != NULL)
7149 return v;
7150 }
14f9c5c9
AS
7151
7152 else if (ada_is_variant_part (type, i))
4c4b4cd2 7153 {
0963b4bd 7154 /* PNH: Do we ever get here? See find_struct_field. */
4c4b4cd2 7155 int j;
5b4ee69b
MS
7156 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7157 i));
4c4b4cd2
PH
7158 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7159
52ce6436 7160 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
4c4b4cd2 7161 {
0963b4bd
MS
7162 struct value *v = ada_search_struct_field /* Force line
7163 break. */
06d5cf63
JB
7164 (name, arg,
7165 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7166 TYPE_FIELD_TYPE (field_type, j));
5b4ee69b 7167
4c4b4cd2
PH
7168 if (v != NULL)
7169 return v;
7170 }
7171 }
14f9c5c9
AS
7172 }
7173 return NULL;
7174}
d2e4a39e 7175
52ce6436
PH
7176static struct value *ada_index_struct_field_1 (int *, struct value *,
7177 int, struct type *);
7178
7179
7180/* Return field #INDEX in ARG, where the index is that returned by
7181 * find_struct_field through its INDEX_P argument. Adjust the address
7182 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
0963b4bd 7183 * If found, return value, else return NULL. */
52ce6436
PH
7184
7185static struct value *
7186ada_index_struct_field (int index, struct value *arg, int offset,
7187 struct type *type)
7188{
7189 return ada_index_struct_field_1 (&index, arg, offset, type);
7190}
7191
7192
7193/* Auxiliary function for ada_index_struct_field. Like
7194 * ada_index_struct_field, but takes index from *INDEX_P and modifies
0963b4bd 7195 * *INDEX_P. */
52ce6436
PH
7196
7197static struct value *
7198ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7199 struct type *type)
7200{
7201 int i;
7202 type = ada_check_typedef (type);
7203
7204 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7205 {
7206 if (TYPE_FIELD_NAME (type, i) == NULL)
7207 continue;
7208 else if (ada_is_wrapper_field (type, i))
7209 {
0963b4bd 7210 struct value *v = /* Do not let indent join lines here. */
52ce6436
PH
7211 ada_index_struct_field_1 (index_p, arg,
7212 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7213 TYPE_FIELD_TYPE (type, i));
5b4ee69b 7214
52ce6436
PH
7215 if (v != NULL)
7216 return v;
7217 }
7218
7219 else if (ada_is_variant_part (type, i))
7220 {
7221 /* PNH: Do we ever get here? See ada_search_struct_field,
0963b4bd 7222 find_struct_field. */
52ce6436
PH
7223 error (_("Cannot assign this kind of variant record"));
7224 }
7225 else if (*index_p == 0)
7226 return ada_value_primitive_field (arg, offset, i, type);
7227 else
7228 *index_p -= 1;
7229 }
7230 return NULL;
7231}
7232
4c4b4cd2
PH
7233/* Given ARG, a value of type (pointer or reference to a)*
7234 structure/union, extract the component named NAME from the ultimate
7235 target structure/union and return it as a value with its
f5938064 7236 appropriate type.
14f9c5c9 7237
4c4b4cd2
PH
7238 The routine searches for NAME among all members of the structure itself
7239 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7240 (e.g., '_parent').
7241
03ee6b2e
PH
7242 If NO_ERR, then simply return NULL in case of error, rather than
7243 calling error. */
14f9c5c9 7244
d2e4a39e 7245struct value *
03ee6b2e 7246ada_value_struct_elt (struct value *arg, char *name, int no_err)
14f9c5c9 7247{
4c4b4cd2 7248 struct type *t, *t1;
d2e4a39e 7249 struct value *v;
14f9c5c9 7250
4c4b4cd2 7251 v = NULL;
df407dfe 7252 t1 = t = ada_check_typedef (value_type (arg));
4c4b4cd2
PH
7253 if (TYPE_CODE (t) == TYPE_CODE_REF)
7254 {
7255 t1 = TYPE_TARGET_TYPE (t);
7256 if (t1 == NULL)
03ee6b2e 7257 goto BadValue;
61ee279c 7258 t1 = ada_check_typedef (t1);
4c4b4cd2 7259 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679 7260 {
994b9211 7261 arg = coerce_ref (arg);
76a01679
JB
7262 t = t1;
7263 }
4c4b4cd2 7264 }
14f9c5c9 7265
4c4b4cd2
PH
7266 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7267 {
7268 t1 = TYPE_TARGET_TYPE (t);
7269 if (t1 == NULL)
03ee6b2e 7270 goto BadValue;
61ee279c 7271 t1 = ada_check_typedef (t1);
4c4b4cd2 7272 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7273 {
7274 arg = value_ind (arg);
7275 t = t1;
7276 }
4c4b4cd2 7277 else
76a01679 7278 break;
4c4b4cd2 7279 }
14f9c5c9 7280
4c4b4cd2 7281 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
03ee6b2e 7282 goto BadValue;
14f9c5c9 7283
4c4b4cd2
PH
7284 if (t1 == t)
7285 v = ada_search_struct_field (name, arg, 0, t);
7286 else
7287 {
7288 int bit_offset, bit_size, byte_offset;
7289 struct type *field_type;
7290 CORE_ADDR address;
7291
76a01679 7292 if (TYPE_CODE (t) == TYPE_CODE_PTR)
b50d69b5 7293 address = value_address (ada_value_ind (arg));
4c4b4cd2 7294 else
b50d69b5 7295 address = value_address (ada_coerce_ref (arg));
14f9c5c9 7296
1ed6ede0 7297 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
76a01679
JB
7298 if (find_struct_field (name, t1, 0,
7299 &field_type, &byte_offset, &bit_offset,
52ce6436 7300 &bit_size, NULL))
76a01679
JB
7301 {
7302 if (bit_size != 0)
7303 {
714e53ab
PH
7304 if (TYPE_CODE (t) == TYPE_CODE_REF)
7305 arg = ada_coerce_ref (arg);
7306 else
7307 arg = ada_value_ind (arg);
76a01679
JB
7308 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7309 bit_offset, bit_size,
7310 field_type);
7311 }
7312 else
f5938064 7313 v = value_at_lazy (field_type, address + byte_offset);
76a01679
JB
7314 }
7315 }
7316
03ee6b2e
PH
7317 if (v != NULL || no_err)
7318 return v;
7319 else
323e0a4a 7320 error (_("There is no member named %s."), name);
14f9c5c9 7321
03ee6b2e
PH
7322 BadValue:
7323 if (no_err)
7324 return NULL;
7325 else
0963b4bd
MS
7326 error (_("Attempt to extract a component of "
7327 "a value that is not a record."));
14f9c5c9
AS
7328}
7329
7330/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7331 If DISPP is non-null, add its byte displacement from the beginning of a
7332 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7333 work for packed fields).
7334
7335 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7336 followed by "___".
14f9c5c9 7337
0963b4bd 7338 TYPE can be either a struct or union. If REFOK, TYPE may also
4c4b4cd2
PH
7339 be a (pointer or reference)+ to a struct or union, and the
7340 ultimate target type will be searched.
14f9c5c9
AS
7341
7342 Looks recursively into variant clauses and parent types.
7343
4c4b4cd2
PH
7344 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7345 TYPE is not a type of the right kind. */
14f9c5c9 7346
4c4b4cd2 7347static struct type *
76a01679
JB
7348ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
7349 int noerr, int *dispp)
14f9c5c9
AS
7350{
7351 int i;
7352
7353 if (name == NULL)
7354 goto BadName;
7355
76a01679 7356 if (refok && type != NULL)
4c4b4cd2
PH
7357 while (1)
7358 {
61ee279c 7359 type = ada_check_typedef (type);
76a01679
JB
7360 if (TYPE_CODE (type) != TYPE_CODE_PTR
7361 && TYPE_CODE (type) != TYPE_CODE_REF)
7362 break;
7363 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7364 }
14f9c5c9 7365
76a01679 7366 if (type == NULL
1265e4aa
JB
7367 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7368 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7369 {
4c4b4cd2 7370 if (noerr)
76a01679 7371 return NULL;
4c4b4cd2 7372 else
76a01679
JB
7373 {
7374 target_terminal_ours ();
7375 gdb_flush (gdb_stdout);
323e0a4a
AC
7376 if (type == NULL)
7377 error (_("Type (null) is not a structure or union type"));
7378 else
7379 {
7380 /* XXX: type_sprint */
7381 fprintf_unfiltered (gdb_stderr, _("Type "));
7382 type_print (type, "", gdb_stderr, -1);
7383 error (_(" is not a structure or union type"));
7384 }
76a01679 7385 }
14f9c5c9
AS
7386 }
7387
7388 type = to_static_fixed_type (type);
7389
7390 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7391 {
0d5cff50 7392 const char *t_field_name = TYPE_FIELD_NAME (type, i);
14f9c5c9
AS
7393 struct type *t;
7394 int disp;
d2e4a39e 7395
14f9c5c9 7396 if (t_field_name == NULL)
4c4b4cd2 7397 continue;
14f9c5c9
AS
7398
7399 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7400 {
7401 if (dispp != NULL)
7402 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
460efde1 7403 return TYPE_FIELD_TYPE (type, i);
4c4b4cd2 7404 }
14f9c5c9
AS
7405
7406 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7407 {
7408 disp = 0;
7409 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7410 0, 1, &disp);
7411 if (t != NULL)
7412 {
7413 if (dispp != NULL)
7414 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7415 return t;
7416 }
7417 }
14f9c5c9
AS
7418
7419 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7420 {
7421 int j;
5b4ee69b
MS
7422 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7423 i));
4c4b4cd2
PH
7424
7425 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7426 {
b1f33ddd
JB
7427 /* FIXME pnh 2008/01/26: We check for a field that is
7428 NOT wrapped in a struct, since the compiler sometimes
7429 generates these for unchecked variant types. Revisit
0963b4bd 7430 if the compiler changes this practice. */
0d5cff50 7431 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
4c4b4cd2 7432 disp = 0;
b1f33ddd
JB
7433 if (v_field_name != NULL
7434 && field_name_match (v_field_name, name))
460efde1 7435 t = TYPE_FIELD_TYPE (field_type, j);
b1f33ddd 7436 else
0963b4bd
MS
7437 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7438 j),
b1f33ddd
JB
7439 name, 0, 1, &disp);
7440
4c4b4cd2
PH
7441 if (t != NULL)
7442 {
7443 if (dispp != NULL)
7444 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7445 return t;
7446 }
7447 }
7448 }
14f9c5c9
AS
7449
7450 }
7451
7452BadName:
d2e4a39e 7453 if (!noerr)
14f9c5c9
AS
7454 {
7455 target_terminal_ours ();
7456 gdb_flush (gdb_stdout);
323e0a4a
AC
7457 if (name == NULL)
7458 {
7459 /* XXX: type_sprint */
7460 fprintf_unfiltered (gdb_stderr, _("Type "));
7461 type_print (type, "", gdb_stderr, -1);
7462 error (_(" has no component named <null>"));
7463 }
7464 else
7465 {
7466 /* XXX: type_sprint */
7467 fprintf_unfiltered (gdb_stderr, _("Type "));
7468 type_print (type, "", gdb_stderr, -1);
7469 error (_(" has no component named %s"), name);
7470 }
14f9c5c9
AS
7471 }
7472
7473 return NULL;
7474}
7475
b1f33ddd
JB
7476/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7477 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7478 represents an unchecked union (that is, the variant part of a
0963b4bd 7479 record that is named in an Unchecked_Union pragma). */
b1f33ddd
JB
7480
7481static int
7482is_unchecked_variant (struct type *var_type, struct type *outer_type)
7483{
7484 char *discrim_name = ada_variant_discrim_name (var_type);
5b4ee69b 7485
b1f33ddd
JB
7486 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7487 == NULL);
7488}
7489
7490
14f9c5c9
AS
7491/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7492 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7493 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7494 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7495
d2e4a39e 7496int
ebf56fd3 7497ada_which_variant_applies (struct type *var_type, struct type *outer_type,
fc1a4b47 7498 const gdb_byte *outer_valaddr)
14f9c5c9
AS
7499{
7500 int others_clause;
7501 int i;
d2e4a39e 7502 char *discrim_name = ada_variant_discrim_name (var_type);
0c281816
JB
7503 struct value *outer;
7504 struct value *discrim;
14f9c5c9
AS
7505 LONGEST discrim_val;
7506
012370f6
TT
7507 /* Using plain value_from_contents_and_address here causes problems
7508 because we will end up trying to resolve a type that is currently
7509 being constructed. */
7510 outer = value_from_contents_and_address_unresolved (outer_type,
7511 outer_valaddr, 0);
0c281816
JB
7512 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7513 if (discrim == NULL)
14f9c5c9 7514 return -1;
0c281816 7515 discrim_val = value_as_long (discrim);
14f9c5c9
AS
7516
7517 others_clause = -1;
7518 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7519 {
7520 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7521 others_clause = i;
14f9c5c9 7522 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7523 return i;
14f9c5c9
AS
7524 }
7525
7526 return others_clause;
7527}
d2e4a39e 7528\f
14f9c5c9
AS
7529
7530
4c4b4cd2 7531 /* Dynamic-Sized Records */
14f9c5c9
AS
7532
7533/* Strategy: The type ostensibly attached to a value with dynamic size
7534 (i.e., a size that is not statically recorded in the debugging
7535 data) does not accurately reflect the size or layout of the value.
7536 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7537 conventional types that are constructed on the fly. */
14f9c5c9
AS
7538
7539/* There is a subtle and tricky problem here. In general, we cannot
7540 determine the size of dynamic records without its data. However,
7541 the 'struct value' data structure, which GDB uses to represent
7542 quantities in the inferior process (the target), requires the size
7543 of the type at the time of its allocation in order to reserve space
7544 for GDB's internal copy of the data. That's why the
7545 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7546 rather than struct value*s.
14f9c5c9
AS
7547
7548 However, GDB's internal history variables ($1, $2, etc.) are
7549 struct value*s containing internal copies of the data that are not, in
7550 general, the same as the data at their corresponding addresses in
7551 the target. Fortunately, the types we give to these values are all
7552 conventional, fixed-size types (as per the strategy described
7553 above), so that we don't usually have to perform the
7554 'to_fixed_xxx_type' conversions to look at their values.
7555 Unfortunately, there is one exception: if one of the internal
7556 history variables is an array whose elements are unconstrained
7557 records, then we will need to create distinct fixed types for each
7558 element selected. */
7559
7560/* The upshot of all of this is that many routines take a (type, host
7561 address, target address) triple as arguments to represent a value.
7562 The host address, if non-null, is supposed to contain an internal
7563 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7564 target at the target address. */
14f9c5c9
AS
7565
7566/* Assuming that VAL0 represents a pointer value, the result of
7567 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7568 dynamic-sized types. */
14f9c5c9 7569
d2e4a39e
AS
7570struct value *
7571ada_value_ind (struct value *val0)
14f9c5c9 7572{
c48db5ca 7573 struct value *val = value_ind (val0);
5b4ee69b 7574
b50d69b5
JG
7575 if (ada_is_tagged_type (value_type (val), 0))
7576 val = ada_tag_value_at_base_address (val);
7577
4c4b4cd2 7578 return ada_to_fixed_value (val);
14f9c5c9
AS
7579}
7580
7581/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7582 qualifiers on VAL0. */
7583
d2e4a39e
AS
7584static struct value *
7585ada_coerce_ref (struct value *val0)
7586{
df407dfe 7587 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
d2e4a39e
AS
7588 {
7589 struct value *val = val0;
5b4ee69b 7590
994b9211 7591 val = coerce_ref (val);
b50d69b5
JG
7592
7593 if (ada_is_tagged_type (value_type (val), 0))
7594 val = ada_tag_value_at_base_address (val);
7595
4c4b4cd2 7596 return ada_to_fixed_value (val);
d2e4a39e
AS
7597 }
7598 else
14f9c5c9
AS
7599 return val0;
7600}
7601
7602/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7603 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7604
7605static unsigned int
ebf56fd3 7606align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7607{
7608 return (off + alignment - 1) & ~(alignment - 1);
7609}
7610
4c4b4cd2 7611/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7612
7613static unsigned int
ebf56fd3 7614field_alignment (struct type *type, int f)
14f9c5c9 7615{
d2e4a39e 7616 const char *name = TYPE_FIELD_NAME (type, f);
64a1bf19 7617 int len;
14f9c5c9
AS
7618 int align_offset;
7619
64a1bf19
JB
7620 /* The field name should never be null, unless the debugging information
7621 is somehow malformed. In this case, we assume the field does not
7622 require any alignment. */
7623 if (name == NULL)
7624 return 1;
7625
7626 len = strlen (name);
7627
4c4b4cd2
PH
7628 if (!isdigit (name[len - 1]))
7629 return 1;
14f9c5c9 7630
d2e4a39e 7631 if (isdigit (name[len - 2]))
14f9c5c9
AS
7632 align_offset = len - 2;
7633 else
7634 align_offset = len - 1;
7635
61012eef 7636 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
14f9c5c9
AS
7637 return TARGET_CHAR_BIT;
7638
4c4b4cd2
PH
7639 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7640}
7641
852dff6c 7642/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
4c4b4cd2 7643
852dff6c
JB
7644static struct symbol *
7645ada_find_any_type_symbol (const char *name)
4c4b4cd2
PH
7646{
7647 struct symbol *sym;
7648
7649 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
4186eb54 7650 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4c4b4cd2
PH
7651 return sym;
7652
4186eb54
KS
7653 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7654 return sym;
14f9c5c9
AS
7655}
7656
dddfab26
UW
7657/* Find a type named NAME. Ignores ambiguity. This routine will look
7658 solely for types defined by debug info, it will not search the GDB
7659 primitive types. */
4c4b4cd2 7660
852dff6c 7661static struct type *
ebf56fd3 7662ada_find_any_type (const char *name)
14f9c5c9 7663{
852dff6c 7664 struct symbol *sym = ada_find_any_type_symbol (name);
14f9c5c9 7665
14f9c5c9 7666 if (sym != NULL)
dddfab26 7667 return SYMBOL_TYPE (sym);
14f9c5c9 7668
dddfab26 7669 return NULL;
14f9c5c9
AS
7670}
7671
739593e0
JB
7672/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7673 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7674 symbol, in which case it is returned. Otherwise, this looks for
7675 symbols whose name is that of NAME_SYM suffixed with "___XR".
7676 Return symbol if found, and NULL otherwise. */
4c4b4cd2
PH
7677
7678struct symbol *
270140bd 7679ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
aeb5907d 7680{
739593e0 7681 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
aeb5907d
JB
7682 struct symbol *sym;
7683
739593e0
JB
7684 if (strstr (name, "___XR") != NULL)
7685 return name_sym;
7686
aeb5907d
JB
7687 sym = find_old_style_renaming_symbol (name, block);
7688
7689 if (sym != NULL)
7690 return sym;
7691
0963b4bd 7692 /* Not right yet. FIXME pnh 7/20/2007. */
852dff6c 7693 sym = ada_find_any_type_symbol (name);
aeb5907d
JB
7694 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7695 return sym;
7696 else
7697 return NULL;
7698}
7699
7700static struct symbol *
270140bd 7701find_old_style_renaming_symbol (const char *name, const struct block *block)
4c4b4cd2 7702{
7f0df278 7703 const struct symbol *function_sym = block_linkage_function (block);
4c4b4cd2
PH
7704 char *rename;
7705
7706 if (function_sym != NULL)
7707 {
7708 /* If the symbol is defined inside a function, NAME is not fully
7709 qualified. This means we need to prepend the function name
7710 as well as adding the ``___XR'' suffix to build the name of
7711 the associated renaming symbol. */
0d5cff50 7712 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
529cad9c
PH
7713 /* Function names sometimes contain suffixes used
7714 for instance to qualify nested subprograms. When building
7715 the XR type name, we need to make sure that this suffix is
7716 not included. So do not include any suffix in the function
7717 name length below. */
69fadcdf 7718 int function_name_len = ada_name_prefix_len (function_name);
76a01679
JB
7719 const int rename_len = function_name_len + 2 /* "__" */
7720 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2 7721
529cad9c 7722 /* Strip the suffix if necessary. */
69fadcdf
JB
7723 ada_remove_trailing_digits (function_name, &function_name_len);
7724 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7725 ada_remove_Xbn_suffix (function_name, &function_name_len);
529cad9c 7726
4c4b4cd2
PH
7727 /* Library-level functions are a special case, as GNAT adds
7728 a ``_ada_'' prefix to the function name to avoid namespace
aeb5907d 7729 pollution. However, the renaming symbols themselves do not
4c4b4cd2
PH
7730 have this prefix, so we need to skip this prefix if present. */
7731 if (function_name_len > 5 /* "_ada_" */
7732 && strstr (function_name, "_ada_") == function_name)
69fadcdf
JB
7733 {
7734 function_name += 5;
7735 function_name_len -= 5;
7736 }
4c4b4cd2
PH
7737
7738 rename = (char *) alloca (rename_len * sizeof (char));
69fadcdf
JB
7739 strncpy (rename, function_name, function_name_len);
7740 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7741 "__%s___XR", name);
4c4b4cd2
PH
7742 }
7743 else
7744 {
7745 const int rename_len = strlen (name) + 6;
5b4ee69b 7746
4c4b4cd2 7747 rename = (char *) alloca (rename_len * sizeof (char));
88c15c34 7748 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
4c4b4cd2
PH
7749 }
7750
852dff6c 7751 return ada_find_any_type_symbol (rename);
4c4b4cd2
PH
7752}
7753
14f9c5c9 7754/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7755 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7756 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7757 otherwise return 0. */
7758
14f9c5c9 7759int
d2e4a39e 7760ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7761{
7762 if (type1 == NULL)
7763 return 1;
7764 else if (type0 == NULL)
7765 return 0;
7766 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7767 return 1;
7768 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7769 return 0;
4c4b4cd2
PH
7770 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7771 return 1;
ad82864c 7772 else if (ada_is_constrained_packed_array_type (type0))
14f9c5c9 7773 return 1;
4c4b4cd2
PH
7774 else if (ada_is_array_descriptor_type (type0)
7775 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7776 return 1;
aeb5907d
JB
7777 else
7778 {
7779 const char *type0_name = type_name_no_tag (type0);
7780 const char *type1_name = type_name_no_tag (type1);
7781
7782 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7783 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7784 return 1;
7785 }
14f9c5c9
AS
7786 return 0;
7787}
7788
7789/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7790 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7791
0d5cff50 7792const char *
d2e4a39e 7793ada_type_name (struct type *type)
14f9c5c9 7794{
d2e4a39e 7795 if (type == NULL)
14f9c5c9
AS
7796 return NULL;
7797 else if (TYPE_NAME (type) != NULL)
7798 return TYPE_NAME (type);
7799 else
7800 return TYPE_TAG_NAME (type);
7801}
7802
b4ba55a1
JB
7803/* Search the list of "descriptive" types associated to TYPE for a type
7804 whose name is NAME. */
7805
7806static struct type *
7807find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7808{
931e5bc3 7809 struct type *result, *tmp;
b4ba55a1 7810
c6044dd1
JB
7811 if (ada_ignore_descriptive_types_p)
7812 return NULL;
7813
b4ba55a1
JB
7814 /* If there no descriptive-type info, then there is no parallel type
7815 to be found. */
7816 if (!HAVE_GNAT_AUX_INFO (type))
7817 return NULL;
7818
7819 result = TYPE_DESCRIPTIVE_TYPE (type);
7820 while (result != NULL)
7821 {
0d5cff50 7822 const char *result_name = ada_type_name (result);
b4ba55a1
JB
7823
7824 if (result_name == NULL)
7825 {
7826 warning (_("unexpected null name on descriptive type"));
7827 return NULL;
7828 }
7829
7830 /* If the names match, stop. */
7831 if (strcmp (result_name, name) == 0)
7832 break;
7833
7834 /* Otherwise, look at the next item on the list, if any. */
7835 if (HAVE_GNAT_AUX_INFO (result))
931e5bc3
JG
7836 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7837 else
7838 tmp = NULL;
7839
7840 /* If not found either, try after having resolved the typedef. */
7841 if (tmp != NULL)
7842 result = tmp;
b4ba55a1 7843 else
931e5bc3 7844 {
f168693b 7845 result = check_typedef (result);
931e5bc3
JG
7846 if (HAVE_GNAT_AUX_INFO (result))
7847 result = TYPE_DESCRIPTIVE_TYPE (result);
7848 else
7849 result = NULL;
7850 }
b4ba55a1
JB
7851 }
7852
7853 /* If we didn't find a match, see whether this is a packed array. With
7854 older compilers, the descriptive type information is either absent or
7855 irrelevant when it comes to packed arrays so the above lookup fails.
7856 Fall back to using a parallel lookup by name in this case. */
12ab9e09 7857 if (result == NULL && ada_is_constrained_packed_array_type (type))
b4ba55a1
JB
7858 return ada_find_any_type (name);
7859
7860 return result;
7861}
7862
7863/* Find a parallel type to TYPE with the specified NAME, using the
7864 descriptive type taken from the debugging information, if available,
7865 and otherwise using the (slower) name-based method. */
7866
7867static struct type *
7868ada_find_parallel_type_with_name (struct type *type, const char *name)
7869{
7870 struct type *result = NULL;
7871
7872 if (HAVE_GNAT_AUX_INFO (type))
7873 result = find_parallel_type_by_descriptive_type (type, name);
7874 else
7875 result = ada_find_any_type (name);
7876
7877 return result;
7878}
7879
7880/* Same as above, but specify the name of the parallel type by appending
4c4b4cd2 7881 SUFFIX to the name of TYPE. */
14f9c5c9 7882
d2e4a39e 7883struct type *
ebf56fd3 7884ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7885{
0d5cff50 7886 char *name;
fe978cb0 7887 const char *type_name = ada_type_name (type);
14f9c5c9 7888 int len;
d2e4a39e 7889
fe978cb0 7890 if (type_name == NULL)
14f9c5c9
AS
7891 return NULL;
7892
fe978cb0 7893 len = strlen (type_name);
14f9c5c9 7894
b4ba55a1 7895 name = (char *) alloca (len + strlen (suffix) + 1);
14f9c5c9 7896
fe978cb0 7897 strcpy (name, type_name);
14f9c5c9
AS
7898 strcpy (name + len, suffix);
7899
b4ba55a1 7900 return ada_find_parallel_type_with_name (type, name);
14f9c5c9
AS
7901}
7902
14f9c5c9 7903/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7904 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7905
d2e4a39e
AS
7906static struct type *
7907dynamic_template_type (struct type *type)
14f9c5c9 7908{
61ee279c 7909 type = ada_check_typedef (type);
14f9c5c9
AS
7910
7911 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7912 || ada_type_name (type) == NULL)
14f9c5c9 7913 return NULL;
d2e4a39e 7914 else
14f9c5c9
AS
7915 {
7916 int len = strlen (ada_type_name (type));
5b4ee69b 7917
4c4b4cd2
PH
7918 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7919 return type;
14f9c5c9 7920 else
4c4b4cd2 7921 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7922 }
7923}
7924
7925/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7926 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7927
d2e4a39e
AS
7928static int
7929is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7930{
7931 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5b4ee69b 7932
d2e4a39e 7933 return name != NULL
14f9c5c9
AS
7934 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7935 && strstr (name, "___XVL") != NULL;
7936}
7937
4c4b4cd2
PH
7938/* The index of the variant field of TYPE, or -1 if TYPE does not
7939 represent a variant record type. */
14f9c5c9 7940
d2e4a39e 7941static int
4c4b4cd2 7942variant_field_index (struct type *type)
14f9c5c9
AS
7943{
7944 int f;
7945
4c4b4cd2
PH
7946 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7947 return -1;
7948
7949 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7950 {
7951 if (ada_is_variant_part (type, f))
7952 return f;
7953 }
7954 return -1;
14f9c5c9
AS
7955}
7956
4c4b4cd2
PH
7957/* A record type with no fields. */
7958
d2e4a39e 7959static struct type *
fe978cb0 7960empty_record (struct type *templ)
14f9c5c9 7961{
fe978cb0 7962 struct type *type = alloc_type_copy (templ);
5b4ee69b 7963
14f9c5c9
AS
7964 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7965 TYPE_NFIELDS (type) = 0;
7966 TYPE_FIELDS (type) = NULL;
b1f33ddd 7967 INIT_CPLUS_SPECIFIC (type);
14f9c5c9
AS
7968 TYPE_NAME (type) = "<empty>";
7969 TYPE_TAG_NAME (type) = NULL;
14f9c5c9
AS
7970 TYPE_LENGTH (type) = 0;
7971 return type;
7972}
7973
7974/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7975 the value of type TYPE at VALADDR or ADDRESS (see comments at
7976 the beginning of this section) VAL according to GNAT conventions.
7977 DVAL0 should describe the (portion of a) record that contains any
df407dfe 7978 necessary discriminants. It should be NULL if value_type (VAL) is
14f9c5c9
AS
7979 an outer-level type (i.e., as opposed to a branch of a variant.) A
7980 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7981 of the variant.
14f9c5c9 7982
4c4b4cd2
PH
7983 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7984 length are not statically known are discarded. As a consequence,
7985 VALADDR, ADDRESS and DVAL0 are ignored.
7986
7987 NOTE: Limitations: For now, we assume that dynamic fields and
7988 variants occupy whole numbers of bytes. However, they need not be
7989 byte-aligned. */
7990
7991struct type *
10a2c479 7992ada_template_to_fixed_record_type_1 (struct type *type,
fc1a4b47 7993 const gdb_byte *valaddr,
4c4b4cd2
PH
7994 CORE_ADDR address, struct value *dval0,
7995 int keep_dynamic_fields)
14f9c5c9 7996{
d2e4a39e
AS
7997 struct value *mark = value_mark ();
7998 struct value *dval;
7999 struct type *rtype;
14f9c5c9 8000 int nfields, bit_len;
4c4b4cd2 8001 int variant_field;
14f9c5c9 8002 long off;
d94e4f4f 8003 int fld_bit_len;
14f9c5c9
AS
8004 int f;
8005
4c4b4cd2
PH
8006 /* Compute the number of fields in this record type that are going
8007 to be processed: unless keep_dynamic_fields, this includes only
8008 fields whose position and length are static will be processed. */
8009 if (keep_dynamic_fields)
8010 nfields = TYPE_NFIELDS (type);
8011 else
8012 {
8013 nfields = 0;
76a01679 8014 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
8015 && !ada_is_variant_part (type, nfields)
8016 && !is_dynamic_field (type, nfields))
8017 nfields++;
8018 }
8019
e9bb382b 8020 rtype = alloc_type_copy (type);
14f9c5c9
AS
8021 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8022 INIT_CPLUS_SPECIFIC (rtype);
8023 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 8024 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
8025 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8026 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8027 TYPE_NAME (rtype) = ada_type_name (type);
8028 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8029 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9 8030
d2e4a39e
AS
8031 off = 0;
8032 bit_len = 0;
4c4b4cd2
PH
8033 variant_field = -1;
8034
14f9c5c9
AS
8035 for (f = 0; f < nfields; f += 1)
8036 {
6c038f32
PH
8037 off = align_value (off, field_alignment (type, f))
8038 + TYPE_FIELD_BITPOS (type, f);
945b3a32 8039 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
d2e4a39e 8040 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 8041
d2e4a39e 8042 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
8043 {
8044 variant_field = f;
d94e4f4f 8045 fld_bit_len = 0;
4c4b4cd2 8046 }
14f9c5c9 8047 else if (is_dynamic_field (type, f))
4c4b4cd2 8048 {
284614f0
JB
8049 const gdb_byte *field_valaddr = valaddr;
8050 CORE_ADDR field_address = address;
8051 struct type *field_type =
8052 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8053
4c4b4cd2 8054 if (dval0 == NULL)
b5304971
JG
8055 {
8056 /* rtype's length is computed based on the run-time
8057 value of discriminants. If the discriminants are not
8058 initialized, the type size may be completely bogus and
0963b4bd 8059 GDB may fail to allocate a value for it. So check the
b5304971 8060 size first before creating the value. */
c1b5a1a6 8061 ada_ensure_varsize_limit (rtype);
012370f6
TT
8062 /* Using plain value_from_contents_and_address here
8063 causes problems because we will end up trying to
8064 resolve a type that is currently being
8065 constructed. */
8066 dval = value_from_contents_and_address_unresolved (rtype,
8067 valaddr,
8068 address);
9f1f738a 8069 rtype = value_type (dval);
b5304971 8070 }
4c4b4cd2
PH
8071 else
8072 dval = dval0;
8073
284614f0
JB
8074 /* If the type referenced by this field is an aligner type, we need
8075 to unwrap that aligner type, because its size might not be set.
8076 Keeping the aligner type would cause us to compute the wrong
8077 size for this field, impacting the offset of the all the fields
8078 that follow this one. */
8079 if (ada_is_aligner_type (field_type))
8080 {
8081 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8082
8083 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8084 field_address = cond_offset_target (field_address, field_offset);
8085 field_type = ada_aligned_type (field_type);
8086 }
8087
8088 field_valaddr = cond_offset_host (field_valaddr,
8089 off / TARGET_CHAR_BIT);
8090 field_address = cond_offset_target (field_address,
8091 off / TARGET_CHAR_BIT);
8092
8093 /* Get the fixed type of the field. Note that, in this case,
8094 we do not want to get the real type out of the tag: if
8095 the current field is the parent part of a tagged record,
8096 we will get the tag of the object. Clearly wrong: the real
8097 type of the parent is not the real type of the child. We
8098 would end up in an infinite loop. */
8099 field_type = ada_get_base_type (field_type);
8100 field_type = ada_to_fixed_type (field_type, field_valaddr,
8101 field_address, dval, 0);
27f2a97b
JB
8102 /* If the field size is already larger than the maximum
8103 object size, then the record itself will necessarily
8104 be larger than the maximum object size. We need to make
8105 this check now, because the size might be so ridiculously
8106 large (due to an uninitialized variable in the inferior)
8107 that it would cause an overflow when adding it to the
8108 record size. */
c1b5a1a6 8109 ada_ensure_varsize_limit (field_type);
284614f0
JB
8110
8111 TYPE_FIELD_TYPE (rtype, f) = field_type;
4c4b4cd2 8112 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
27f2a97b
JB
8113 /* The multiplication can potentially overflow. But because
8114 the field length has been size-checked just above, and
8115 assuming that the maximum size is a reasonable value,
8116 an overflow should not happen in practice. So rather than
8117 adding overflow recovery code to this already complex code,
8118 we just assume that it's not going to happen. */
d94e4f4f 8119 fld_bit_len =
4c4b4cd2
PH
8120 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8121 }
14f9c5c9 8122 else
4c4b4cd2 8123 {
5ded5331
JB
8124 /* Note: If this field's type is a typedef, it is important
8125 to preserve the typedef layer.
8126
8127 Otherwise, we might be transforming a typedef to a fat
8128 pointer (encoding a pointer to an unconstrained array),
8129 into a basic fat pointer (encoding an unconstrained
8130 array). As both types are implemented using the same
8131 structure, the typedef is the only clue which allows us
8132 to distinguish between the two options. Stripping it
8133 would prevent us from printing this field appropriately. */
8134 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
4c4b4cd2
PH
8135 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8136 if (TYPE_FIELD_BITSIZE (type, f) > 0)
d94e4f4f 8137 fld_bit_len =
4c4b4cd2
PH
8138 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8139 else
5ded5331
JB
8140 {
8141 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8142
8143 /* We need to be careful of typedefs when computing
8144 the length of our field. If this is a typedef,
8145 get the length of the target type, not the length
8146 of the typedef. */
8147 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8148 field_type = ada_typedef_target_type (field_type);
8149
8150 fld_bit_len =
8151 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8152 }
4c4b4cd2 8153 }
14f9c5c9 8154 if (off + fld_bit_len > bit_len)
4c4b4cd2 8155 bit_len = off + fld_bit_len;
d94e4f4f 8156 off += fld_bit_len;
4c4b4cd2
PH
8157 TYPE_LENGTH (rtype) =
8158 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 8159 }
4c4b4cd2
PH
8160
8161 /* We handle the variant part, if any, at the end because of certain
b1f33ddd 8162 odd cases in which it is re-ordered so as NOT to be the last field of
4c4b4cd2
PH
8163 the record. This can happen in the presence of representation
8164 clauses. */
8165 if (variant_field >= 0)
8166 {
8167 struct type *branch_type;
8168
8169 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8170
8171 if (dval0 == NULL)
9f1f738a 8172 {
012370f6
TT
8173 /* Using plain value_from_contents_and_address here causes
8174 problems because we will end up trying to resolve a type
8175 that is currently being constructed. */
8176 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8177 address);
9f1f738a
SA
8178 rtype = value_type (dval);
8179 }
4c4b4cd2
PH
8180 else
8181 dval = dval0;
8182
8183 branch_type =
8184 to_fixed_variant_branch_type
8185 (TYPE_FIELD_TYPE (type, variant_field),
8186 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8187 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8188 if (branch_type == NULL)
8189 {
8190 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8191 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8192 TYPE_NFIELDS (rtype) -= 1;
8193 }
8194 else
8195 {
8196 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8197 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8198 fld_bit_len =
8199 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8200 TARGET_CHAR_BIT;
8201 if (off + fld_bit_len > bit_len)
8202 bit_len = off + fld_bit_len;
8203 TYPE_LENGTH (rtype) =
8204 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8205 }
8206 }
8207
714e53ab
PH
8208 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8209 should contain the alignment of that record, which should be a strictly
8210 positive value. If null or negative, then something is wrong, most
8211 probably in the debug info. In that case, we don't round up the size
0963b4bd 8212 of the resulting type. If this record is not part of another structure,
714e53ab
PH
8213 the current RTYPE length might be good enough for our purposes. */
8214 if (TYPE_LENGTH (type) <= 0)
8215 {
323e0a4a
AC
8216 if (TYPE_NAME (rtype))
8217 warning (_("Invalid type size for `%s' detected: %d."),
8218 TYPE_NAME (rtype), TYPE_LENGTH (type));
8219 else
8220 warning (_("Invalid type size for <unnamed> detected: %d."),
8221 TYPE_LENGTH (type));
714e53ab
PH
8222 }
8223 else
8224 {
8225 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8226 TYPE_LENGTH (type));
8227 }
14f9c5c9
AS
8228
8229 value_free_to_mark (mark);
d2e4a39e 8230 if (TYPE_LENGTH (rtype) > varsize_limit)
323e0a4a 8231 error (_("record type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8232 return rtype;
8233}
8234
4c4b4cd2
PH
8235/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8236 of 1. */
14f9c5c9 8237
d2e4a39e 8238static struct type *
fc1a4b47 8239template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
4c4b4cd2
PH
8240 CORE_ADDR address, struct value *dval0)
8241{
8242 return ada_template_to_fixed_record_type_1 (type, valaddr,
8243 address, dval0, 1);
8244}
8245
8246/* An ordinary record type in which ___XVL-convention fields and
8247 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8248 static approximations, containing all possible fields. Uses
8249 no runtime values. Useless for use in values, but that's OK,
8250 since the results are used only for type determinations. Works on both
8251 structs and unions. Representation note: to save space, we memorize
8252 the result of this function in the TYPE_TARGET_TYPE of the
8253 template type. */
8254
8255static struct type *
8256template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
8257{
8258 struct type *type;
8259 int nfields;
8260 int f;
8261
9e195661
PMR
8262 /* No need no do anything if the input type is already fixed. */
8263 if (TYPE_FIXED_INSTANCE (type0))
8264 return type0;
8265
8266 /* Likewise if we already have computed the static approximation. */
4c4b4cd2
PH
8267 if (TYPE_TARGET_TYPE (type0) != NULL)
8268 return TYPE_TARGET_TYPE (type0);
8269
9e195661 8270 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
4c4b4cd2 8271 type = type0;
9e195661
PMR
8272 nfields = TYPE_NFIELDS (type0);
8273
8274 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8275 recompute all over next time. */
8276 TYPE_TARGET_TYPE (type0) = type;
14f9c5c9
AS
8277
8278 for (f = 0; f < nfields; f += 1)
8279 {
460efde1 8280 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
4c4b4cd2 8281 struct type *new_type;
14f9c5c9 8282
4c4b4cd2 8283 if (is_dynamic_field (type0, f))
460efde1
JB
8284 {
8285 field_type = ada_check_typedef (field_type);
8286 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8287 }
14f9c5c9 8288 else
f192137b 8289 new_type = static_unwrap_type (field_type);
9e195661
PMR
8290
8291 if (new_type != field_type)
8292 {
8293 /* Clone TYPE0 only the first time we get a new field type. */
8294 if (type == type0)
8295 {
8296 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8297 TYPE_CODE (type) = TYPE_CODE (type0);
8298 INIT_CPLUS_SPECIFIC (type);
8299 TYPE_NFIELDS (type) = nfields;
8300 TYPE_FIELDS (type) = (struct field *)
8301 TYPE_ALLOC (type, nfields * sizeof (struct field));
8302 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8303 sizeof (struct field) * nfields);
8304 TYPE_NAME (type) = ada_type_name (type0);
8305 TYPE_TAG_NAME (type) = NULL;
8306 TYPE_FIXED_INSTANCE (type) = 1;
8307 TYPE_LENGTH (type) = 0;
8308 }
8309 TYPE_FIELD_TYPE (type, f) = new_type;
8310 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8311 }
14f9c5c9 8312 }
9e195661 8313
14f9c5c9
AS
8314 return type;
8315}
8316
4c4b4cd2 8317/* Given an object of type TYPE whose contents are at VALADDR and
5823c3ef
JB
8318 whose address in memory is ADDRESS, returns a revision of TYPE,
8319 which should be a non-dynamic-sized record, in which the variant
8320 part, if any, is replaced with the appropriate branch. Looks
4c4b4cd2
PH
8321 for discriminant values in DVAL0, which can be NULL if the record
8322 contains the necessary discriminant values. */
8323
d2e4a39e 8324static struct type *
fc1a4b47 8325to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
4c4b4cd2 8326 CORE_ADDR address, struct value *dval0)
14f9c5c9 8327{
d2e4a39e 8328 struct value *mark = value_mark ();
4c4b4cd2 8329 struct value *dval;
d2e4a39e 8330 struct type *rtype;
14f9c5c9
AS
8331 struct type *branch_type;
8332 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 8333 int variant_field = variant_field_index (type);
14f9c5c9 8334
4c4b4cd2 8335 if (variant_field == -1)
14f9c5c9
AS
8336 return type;
8337
4c4b4cd2 8338 if (dval0 == NULL)
9f1f738a
SA
8339 {
8340 dval = value_from_contents_and_address (type, valaddr, address);
8341 type = value_type (dval);
8342 }
4c4b4cd2
PH
8343 else
8344 dval = dval0;
8345
e9bb382b 8346 rtype = alloc_type_copy (type);
14f9c5c9 8347 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
8348 INIT_CPLUS_SPECIFIC (rtype);
8349 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
8350 TYPE_FIELDS (rtype) =
8351 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8352 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 8353 sizeof (struct field) * nfields);
14f9c5c9
AS
8354 TYPE_NAME (rtype) = ada_type_name (type);
8355 TYPE_TAG_NAME (rtype) = NULL;
876cecd0 8356 TYPE_FIXED_INSTANCE (rtype) = 1;
14f9c5c9
AS
8357 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8358
4c4b4cd2
PH
8359 branch_type = to_fixed_variant_branch_type
8360 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 8361 cond_offset_host (valaddr,
4c4b4cd2
PH
8362 TYPE_FIELD_BITPOS (type, variant_field)
8363 / TARGET_CHAR_BIT),
d2e4a39e 8364 cond_offset_target (address,
4c4b4cd2
PH
8365 TYPE_FIELD_BITPOS (type, variant_field)
8366 / TARGET_CHAR_BIT), dval);
d2e4a39e 8367 if (branch_type == NULL)
14f9c5c9 8368 {
4c4b4cd2 8369 int f;
5b4ee69b 8370
4c4b4cd2
PH
8371 for (f = variant_field + 1; f < nfields; f += 1)
8372 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 8373 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
8374 }
8375 else
8376 {
4c4b4cd2
PH
8377 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8378 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8379 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 8380 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 8381 }
4c4b4cd2 8382 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 8383
4c4b4cd2 8384 value_free_to_mark (mark);
14f9c5c9
AS
8385 return rtype;
8386}
8387
8388/* An ordinary record type (with fixed-length fields) that describes
8389 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8390 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
8391 should be in DVAL, a record value; it may be NULL if the object
8392 at ADDR itself contains any necessary discriminant values.
8393 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8394 values from the record are needed. Except in the case that DVAL,
8395 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8396 unchecked) is replaced by a particular branch of the variant.
8397
8398 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8399 is questionable and may be removed. It can arise during the
8400 processing of an unconstrained-array-of-record type where all the
8401 variant branches have exactly the same size. This is because in
8402 such cases, the compiler does not bother to use the XVS convention
8403 when encoding the record. I am currently dubious of this
8404 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 8405
d2e4a39e 8406static struct type *
fc1a4b47 8407to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
4c4b4cd2 8408 CORE_ADDR address, struct value *dval)
14f9c5c9 8409{
d2e4a39e 8410 struct type *templ_type;
14f9c5c9 8411
876cecd0 8412 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8413 return type0;
8414
d2e4a39e 8415 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
8416
8417 if (templ_type != NULL)
8418 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
8419 else if (variant_field_index (type0) >= 0)
8420 {
8421 if (dval == NULL && valaddr == NULL && address == 0)
8422 return type0;
8423 return to_record_with_fixed_variant_part (type0, valaddr, address,
8424 dval);
8425 }
14f9c5c9
AS
8426 else
8427 {
876cecd0 8428 TYPE_FIXED_INSTANCE (type0) = 1;
14f9c5c9
AS
8429 return type0;
8430 }
8431
8432}
8433
8434/* An ordinary record type (with fixed-length fields) that describes
8435 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8436 union type. Any necessary discriminants' values should be in DVAL,
8437 a record value. That is, this routine selects the appropriate
8438 branch of the union at ADDR according to the discriminant value
b1f33ddd 8439 indicated in the union's type name. Returns VAR_TYPE0 itself if
0963b4bd 8440 it represents a variant subject to a pragma Unchecked_Union. */
14f9c5c9 8441
d2e4a39e 8442static struct type *
fc1a4b47 8443to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
4c4b4cd2 8444 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8445{
8446 int which;
d2e4a39e
AS
8447 struct type *templ_type;
8448 struct type *var_type;
14f9c5c9
AS
8449
8450 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8451 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 8452 else
14f9c5c9
AS
8453 var_type = var_type0;
8454
8455 templ_type = ada_find_parallel_type (var_type, "___XVU");
8456
8457 if (templ_type != NULL)
8458 var_type = templ_type;
8459
b1f33ddd
JB
8460 if (is_unchecked_variant (var_type, value_type (dval)))
8461 return var_type0;
d2e4a39e
AS
8462 which =
8463 ada_which_variant_applies (var_type,
0fd88904 8464 value_type (dval), value_contents (dval));
14f9c5c9
AS
8465
8466 if (which < 0)
e9bb382b 8467 return empty_record (var_type);
14f9c5c9 8468 else if (is_dynamic_field (var_type, which))
4c4b4cd2 8469 return to_fixed_record_type
d2e4a39e
AS
8470 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8471 valaddr, address, dval);
4c4b4cd2 8472 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
8473 return
8474 to_fixed_record_type
8475 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
8476 else
8477 return TYPE_FIELD_TYPE (var_type, which);
8478}
8479
8908fca5
JB
8480/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8481 ENCODING_TYPE, a type following the GNAT conventions for discrete
8482 type encodings, only carries redundant information. */
8483
8484static int
8485ada_is_redundant_range_encoding (struct type *range_type,
8486 struct type *encoding_type)
8487{
8488 struct type *fixed_range_type;
8489 char *bounds_str;
8490 int n;
8491 LONGEST lo, hi;
8492
8493 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8494
005e2509
JB
8495 if (TYPE_CODE (get_base_type (range_type))
8496 != TYPE_CODE (get_base_type (encoding_type)))
8497 {
8498 /* The compiler probably used a simple base type to describe
8499 the range type instead of the range's actual base type,
8500 expecting us to get the real base type from the encoding
8501 anyway. In this situation, the encoding cannot be ignored
8502 as redundant. */
8503 return 0;
8504 }
8505
8908fca5
JB
8506 if (is_dynamic_type (range_type))
8507 return 0;
8508
8509 if (TYPE_NAME (encoding_type) == NULL)
8510 return 0;
8511
8512 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8513 if (bounds_str == NULL)
8514 return 0;
8515
8516 n = 8; /* Skip "___XDLU_". */
8517 if (!ada_scan_number (bounds_str, n, &lo, &n))
8518 return 0;
8519 if (TYPE_LOW_BOUND (range_type) != lo)
8520 return 0;
8521
8522 n += 2; /* Skip the "__" separator between the two bounds. */
8523 if (!ada_scan_number (bounds_str, n, &hi, &n))
8524 return 0;
8525 if (TYPE_HIGH_BOUND (range_type) != hi)
8526 return 0;
8527
8528 return 1;
8529}
8530
8531/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8532 a type following the GNAT encoding for describing array type
8533 indices, only carries redundant information. */
8534
8535static int
8536ada_is_redundant_index_type_desc (struct type *array_type,
8537 struct type *desc_type)
8538{
8539 struct type *this_layer = check_typedef (array_type);
8540 int i;
8541
8542 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8543 {
8544 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8545 TYPE_FIELD_TYPE (desc_type, i)))
8546 return 0;
8547 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8548 }
8549
8550 return 1;
8551}
8552
14f9c5c9
AS
8553/* Assuming that TYPE0 is an array type describing the type of a value
8554 at ADDR, and that DVAL describes a record containing any
8555 discriminants used in TYPE0, returns a type for the value that
8556 contains no dynamic components (that is, no components whose sizes
8557 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8558 true, gives an error message if the resulting type's size is over
4c4b4cd2 8559 varsize_limit. */
14f9c5c9 8560
d2e4a39e
AS
8561static struct type *
8562to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 8563 int ignore_too_big)
14f9c5c9 8564{
d2e4a39e
AS
8565 struct type *index_type_desc;
8566 struct type *result;
ad82864c 8567 int constrained_packed_array_p;
931e5bc3 8568 static const char *xa_suffix = "___XA";
14f9c5c9 8569
b0dd7688 8570 type0 = ada_check_typedef (type0);
284614f0 8571 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2 8572 return type0;
14f9c5c9 8573
ad82864c
JB
8574 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8575 if (constrained_packed_array_p)
8576 type0 = decode_constrained_packed_array_type (type0);
284614f0 8577
931e5bc3
JG
8578 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8579
8580 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8581 encoding suffixed with 'P' may still be generated. If so,
8582 it should be used to find the XA type. */
8583
8584 if (index_type_desc == NULL)
8585 {
1da0522e 8586 const char *type_name = ada_type_name (type0);
931e5bc3 8587
1da0522e 8588 if (type_name != NULL)
931e5bc3 8589 {
1da0522e 8590 const int len = strlen (type_name);
931e5bc3
JG
8591 char *name = (char *) alloca (len + strlen (xa_suffix));
8592
1da0522e 8593 if (type_name[len - 1] == 'P')
931e5bc3 8594 {
1da0522e 8595 strcpy (name, type_name);
931e5bc3
JG
8596 strcpy (name + len - 1, xa_suffix);
8597 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8598 }
8599 }
8600 }
8601
28c85d6c 8602 ada_fixup_array_indexes_type (index_type_desc);
8908fca5
JB
8603 if (index_type_desc != NULL
8604 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8605 {
8606 /* Ignore this ___XA parallel type, as it does not bring any
8607 useful information. This allows us to avoid creating fixed
8608 versions of the array's index types, which would be identical
8609 to the original ones. This, in turn, can also help avoid
8610 the creation of fixed versions of the array itself. */
8611 index_type_desc = NULL;
8612 }
8613
14f9c5c9
AS
8614 if (index_type_desc == NULL)
8615 {
61ee279c 8616 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
5b4ee69b 8617
14f9c5c9 8618 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
8619 depend on the contents of the array in properly constructed
8620 debugging data. */
529cad9c
PH
8621 /* Create a fixed version of the array element type.
8622 We're not providing the address of an element here,
e1d5a0d2 8623 and thus the actual object value cannot be inspected to do
529cad9c
PH
8624 the conversion. This should not be a problem, since arrays of
8625 unconstrained objects are not allowed. In particular, all
8626 the elements of an array of a tagged type should all be of
8627 the same type specified in the debugging info. No need to
8628 consult the object tag. */
1ed6ede0 8629 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
14f9c5c9 8630
284614f0
JB
8631 /* Make sure we always create a new array type when dealing with
8632 packed array types, since we're going to fix-up the array
8633 type length and element bitsize a little further down. */
ad82864c 8634 if (elt_type0 == elt_type && !constrained_packed_array_p)
4c4b4cd2 8635 result = type0;
14f9c5c9 8636 else
e9bb382b 8637 result = create_array_type (alloc_type_copy (type0),
4c4b4cd2 8638 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8639 }
8640 else
8641 {
8642 int i;
8643 struct type *elt_type0;
8644
8645 elt_type0 = type0;
8646 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8647 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8648
8649 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8650 depend on the contents of the array in properly constructed
8651 debugging data. */
529cad9c
PH
8652 /* Create a fixed version of the array element type.
8653 We're not providing the address of an element here,
e1d5a0d2 8654 and thus the actual object value cannot be inspected to do
529cad9c
PH
8655 the conversion. This should not be a problem, since arrays of
8656 unconstrained objects are not allowed. In particular, all
8657 the elements of an array of a tagged type should all be of
8658 the same type specified in the debugging info. No need to
8659 consult the object tag. */
1ed6ede0
JB
8660 result =
8661 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
1ce677a4
UW
8662
8663 elt_type0 = type0;
14f9c5c9 8664 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8665 {
8666 struct type *range_type =
28c85d6c 8667 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
5b4ee69b 8668
e9bb382b 8669 result = create_array_type (alloc_type_copy (elt_type0),
4c4b4cd2 8670 result, range_type);
1ce677a4 8671 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
4c4b4cd2 8672 }
d2e4a39e 8673 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
323e0a4a 8674 error (_("array type with dynamic size is larger than varsize-limit"));
14f9c5c9
AS
8675 }
8676
2e6fda7d
JB
8677 /* We want to preserve the type name. This can be useful when
8678 trying to get the type name of a value that has already been
8679 printed (for instance, if the user did "print VAR; whatis $". */
8680 TYPE_NAME (result) = TYPE_NAME (type0);
8681
ad82864c 8682 if (constrained_packed_array_p)
284614f0
JB
8683 {
8684 /* So far, the resulting type has been created as if the original
8685 type was a regular (non-packed) array type. As a result, the
8686 bitsize of the array elements needs to be set again, and the array
8687 length needs to be recomputed based on that bitsize. */
8688 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8689 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8690
8691 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8692 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8693 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8694 TYPE_LENGTH (result)++;
8695 }
8696
876cecd0 8697 TYPE_FIXED_INSTANCE (result) = 1;
14f9c5c9 8698 return result;
d2e4a39e 8699}
14f9c5c9
AS
8700
8701
8702/* A standard type (containing no dynamically sized components)
8703 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8704 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2 8705 and may be NULL if there are none, or if the object of type TYPE at
529cad9c
PH
8706 ADDRESS or in VALADDR contains these discriminants.
8707
1ed6ede0
JB
8708 If CHECK_TAG is not null, in the case of tagged types, this function
8709 attempts to locate the object's tag and use it to compute the actual
8710 type. However, when ADDRESS is null, we cannot use it to determine the
8711 location of the tag, and therefore compute the tagged type's actual type.
8712 So we return the tagged type without consulting the tag. */
529cad9c 8713
f192137b
JB
8714static struct type *
8715ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
1ed6ede0 8716 CORE_ADDR address, struct value *dval, int check_tag)
14f9c5c9 8717{
61ee279c 8718 type = ada_check_typedef (type);
d2e4a39e
AS
8719 switch (TYPE_CODE (type))
8720 {
8721 default:
14f9c5c9 8722 return type;
d2e4a39e 8723 case TYPE_CODE_STRUCT:
4c4b4cd2 8724 {
76a01679 8725 struct type *static_type = to_static_fixed_type (type);
1ed6ede0
JB
8726 struct type *fixed_record_type =
8727 to_fixed_record_type (type, valaddr, address, NULL);
5b4ee69b 8728
529cad9c
PH
8729 /* If STATIC_TYPE is a tagged type and we know the object's address,
8730 then we can determine its tag, and compute the object's actual
0963b4bd 8731 type from there. Note that we have to use the fixed record
1ed6ede0
JB
8732 type (the parent part of the record may have dynamic fields
8733 and the way the location of _tag is expressed may depend on
8734 them). */
529cad9c 8735
1ed6ede0 8736 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
76a01679 8737 {
b50d69b5
JG
8738 struct value *tag =
8739 value_tag_from_contents_and_address
8740 (fixed_record_type,
8741 valaddr,
8742 address);
8743 struct type *real_type = type_from_tag (tag);
8744 struct value *obj =
8745 value_from_contents_and_address (fixed_record_type,
8746 valaddr,
8747 address);
9f1f738a 8748 fixed_record_type = value_type (obj);
76a01679 8749 if (real_type != NULL)
b50d69b5
JG
8750 return to_fixed_record_type
8751 (real_type, NULL,
8752 value_address (ada_tag_value_at_base_address (obj)), NULL);
76a01679 8753 }
4af88198
JB
8754
8755 /* Check to see if there is a parallel ___XVZ variable.
8756 If there is, then it provides the actual size of our type. */
8757 else if (ada_type_name (fixed_record_type) != NULL)
8758 {
0d5cff50 8759 const char *name = ada_type_name (fixed_record_type);
4af88198
JB
8760 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8761 int xvz_found = 0;
8762 LONGEST size;
8763
88c15c34 8764 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
4af88198
JB
8765 size = get_int_var_value (xvz_name, &xvz_found);
8766 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8767 {
8768 fixed_record_type = copy_type (fixed_record_type);
8769 TYPE_LENGTH (fixed_record_type) = size;
8770
8771 /* The FIXED_RECORD_TYPE may have be a stub. We have
8772 observed this when the debugging info is STABS, and
8773 apparently it is something that is hard to fix.
8774
8775 In practice, we don't need the actual type definition
8776 at all, because the presence of the XVZ variable allows us
8777 to assume that there must be a XVS type as well, which we
8778 should be able to use later, when we need the actual type
8779 definition.
8780
8781 In the meantime, pretend that the "fixed" type we are
8782 returning is NOT a stub, because this can cause trouble
8783 when using this type to create new types targeting it.
8784 Indeed, the associated creation routines often check
8785 whether the target type is a stub and will try to replace
0963b4bd 8786 it, thus using a type with the wrong size. This, in turn,
4af88198
JB
8787 might cause the new type to have the wrong size too.
8788 Consider the case of an array, for instance, where the size
8789 of the array is computed from the number of elements in
8790 our array multiplied by the size of its element. */
8791 TYPE_STUB (fixed_record_type) = 0;
8792 }
8793 }
1ed6ede0 8794 return fixed_record_type;
4c4b4cd2 8795 }
d2e4a39e 8796 case TYPE_CODE_ARRAY:
4c4b4cd2 8797 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8798 case TYPE_CODE_UNION:
8799 if (dval == NULL)
4c4b4cd2 8800 return type;
d2e4a39e 8801 else
4c4b4cd2 8802 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8803 }
14f9c5c9
AS
8804}
8805
f192137b
JB
8806/* The same as ada_to_fixed_type_1, except that it preserves the type
8807 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
96dbd2c1
JB
8808
8809 The typedef layer needs be preserved in order to differentiate between
8810 arrays and array pointers when both types are implemented using the same
8811 fat pointer. In the array pointer case, the pointer is encoded as
8812 a typedef of the pointer type. For instance, considering:
8813
8814 type String_Access is access String;
8815 S1 : String_Access := null;
8816
8817 To the debugger, S1 is defined as a typedef of type String. But
8818 to the user, it is a pointer. So if the user tries to print S1,
8819 we should not dereference the array, but print the array address
8820 instead.
8821
8822 If we didn't preserve the typedef layer, we would lose the fact that
8823 the type is to be presented as a pointer (needs de-reference before
8824 being printed). And we would also use the source-level type name. */
f192137b
JB
8825
8826struct type *
8827ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8828 CORE_ADDR address, struct value *dval, int check_tag)
8829
8830{
8831 struct type *fixed_type =
8832 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8833
96dbd2c1
JB
8834 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8835 then preserve the typedef layer.
8836
8837 Implementation note: We can only check the main-type portion of
8838 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8839 from TYPE now returns a type that has the same instance flags
8840 as TYPE. For instance, if TYPE is a "typedef const", and its
8841 target type is a "struct", then the typedef elimination will return
8842 a "const" version of the target type. See check_typedef for more
8843 details about how the typedef layer elimination is done.
8844
8845 brobecker/2010-11-19: It seems to me that the only case where it is
8846 useful to preserve the typedef layer is when dealing with fat pointers.
8847 Perhaps, we could add a check for that and preserve the typedef layer
8848 only in that situation. But this seems unecessary so far, probably
8849 because we call check_typedef/ada_check_typedef pretty much everywhere.
8850 */
f192137b 8851 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
720d1a40 8852 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
96dbd2c1 8853 == TYPE_MAIN_TYPE (fixed_type)))
f192137b
JB
8854 return type;
8855
8856 return fixed_type;
8857}
8858
14f9c5c9 8859/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8860 TYPE0, but based on no runtime data. */
14f9c5c9 8861
d2e4a39e
AS
8862static struct type *
8863to_static_fixed_type (struct type *type0)
14f9c5c9 8864{
d2e4a39e 8865 struct type *type;
14f9c5c9
AS
8866
8867 if (type0 == NULL)
8868 return NULL;
8869
876cecd0 8870 if (TYPE_FIXED_INSTANCE (type0))
4c4b4cd2
PH
8871 return type0;
8872
61ee279c 8873 type0 = ada_check_typedef (type0);
d2e4a39e 8874
14f9c5c9
AS
8875 switch (TYPE_CODE (type0))
8876 {
8877 default:
8878 return type0;
8879 case TYPE_CODE_STRUCT:
8880 type = dynamic_template_type (type0);
d2e4a39e 8881 if (type != NULL)
4c4b4cd2
PH
8882 return template_to_static_fixed_type (type);
8883 else
8884 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8885 case TYPE_CODE_UNION:
8886 type = ada_find_parallel_type (type0, "___XVU");
8887 if (type != NULL)
4c4b4cd2
PH
8888 return template_to_static_fixed_type (type);
8889 else
8890 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8891 }
8892}
8893
4c4b4cd2
PH
8894/* A static approximation of TYPE with all type wrappers removed. */
8895
d2e4a39e
AS
8896static struct type *
8897static_unwrap_type (struct type *type)
14f9c5c9
AS
8898{
8899 if (ada_is_aligner_type (type))
8900 {
61ee279c 8901 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
14f9c5c9 8902 if (ada_type_name (type1) == NULL)
4c4b4cd2 8903 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8904
8905 return static_unwrap_type (type1);
8906 }
d2e4a39e 8907 else
14f9c5c9 8908 {
d2e4a39e 8909 struct type *raw_real_type = ada_get_base_type (type);
5b4ee69b 8910
d2e4a39e 8911 if (raw_real_type == type)
4c4b4cd2 8912 return type;
14f9c5c9 8913 else
4c4b4cd2 8914 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8915 }
8916}
8917
8918/* In some cases, incomplete and private types require
4c4b4cd2 8919 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8920 type Foo;
8921 type FooP is access Foo;
8922 V: FooP;
8923 type Foo is array ...;
4c4b4cd2 8924 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8925 cross-references to such types, we instead substitute for FooP a
8926 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8927 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8928
8929/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8930 exists, otherwise TYPE. */
8931
d2e4a39e 8932struct type *
61ee279c 8933ada_check_typedef (struct type *type)
14f9c5c9 8934{
727e3d2e
JB
8935 if (type == NULL)
8936 return NULL;
8937
720d1a40
JB
8938 /* If our type is a typedef type of a fat pointer, then we're done.
8939 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8940 what allows us to distinguish between fat pointers that represent
8941 array types, and fat pointers that represent array access types
8942 (in both cases, the compiler implements them as fat pointers). */
8943 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8944 && is_thick_pntr (ada_typedef_target_type (type)))
8945 return type;
8946
f168693b 8947 type = check_typedef (type);
14f9c5c9 8948 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
529cad9c 8949 || !TYPE_STUB (type)
14f9c5c9
AS
8950 || TYPE_TAG_NAME (type) == NULL)
8951 return type;
d2e4a39e 8952 else
14f9c5c9 8953 {
0d5cff50 8954 const char *name = TYPE_TAG_NAME (type);
d2e4a39e 8955 struct type *type1 = ada_find_any_type (name);
5b4ee69b 8956
05e522ef
JB
8957 if (type1 == NULL)
8958 return type;
8959
8960 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8961 stubs pointing to arrays, as we don't create symbols for array
3a867c22
JB
8962 types, only for the typedef-to-array types). If that's the case,
8963 strip the typedef layer. */
8964 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8965 type1 = ada_check_typedef (type1);
8966
8967 return type1;
14f9c5c9
AS
8968 }
8969}
8970
8971/* A value representing the data at VALADDR/ADDRESS as described by
8972 type TYPE0, but with a standard (static-sized) type that correctly
8973 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8974 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8975 creation of struct values]. */
14f9c5c9 8976
4c4b4cd2
PH
8977static struct value *
8978ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8979 struct value *val0)
14f9c5c9 8980{
1ed6ede0 8981 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
5b4ee69b 8982
14f9c5c9
AS
8983 if (type == type0 && val0 != NULL)
8984 return val0;
d2e4a39e 8985 else
4c4b4cd2
PH
8986 return value_from_contents_and_address (type, 0, address);
8987}
8988
8989/* A value representing VAL, but with a standard (static-sized) type
8990 that correctly describes it. Does not necessarily create a new
8991 value. */
8992
0c3acc09 8993struct value *
4c4b4cd2
PH
8994ada_to_fixed_value (struct value *val)
8995{
c48db5ca
JB
8996 val = unwrap_value (val);
8997 val = ada_to_fixed_value_create (value_type (val),
8998 value_address (val),
8999 val);
9000 return val;
14f9c5c9 9001}
d2e4a39e 9002\f
14f9c5c9 9003
14f9c5c9
AS
9004/* Attributes */
9005
4c4b4cd2
PH
9006/* Table mapping attribute numbers to names.
9007 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 9008
d2e4a39e 9009static const char *attribute_names[] = {
14f9c5c9
AS
9010 "<?>",
9011
d2e4a39e 9012 "first",
14f9c5c9
AS
9013 "last",
9014 "length",
9015 "image",
14f9c5c9
AS
9016 "max",
9017 "min",
4c4b4cd2
PH
9018 "modulus",
9019 "pos",
9020 "size",
9021 "tag",
14f9c5c9 9022 "val",
14f9c5c9
AS
9023 0
9024};
9025
d2e4a39e 9026const char *
4c4b4cd2 9027ada_attribute_name (enum exp_opcode n)
14f9c5c9 9028{
4c4b4cd2
PH
9029 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9030 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
9031 else
9032 return attribute_names[0];
9033}
9034
4c4b4cd2 9035/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 9036
4c4b4cd2
PH
9037static LONGEST
9038pos_atr (struct value *arg)
14f9c5c9 9039{
24209737
PH
9040 struct value *val = coerce_ref (arg);
9041 struct type *type = value_type (val);
aa715135 9042 LONGEST result;
14f9c5c9 9043
d2e4a39e 9044 if (!discrete_type_p (type))
323e0a4a 9045 error (_("'POS only defined on discrete types"));
14f9c5c9 9046
aa715135
JG
9047 if (!discrete_position (type, value_as_long (val), &result))
9048 error (_("enumeration value is invalid: can't find 'POS"));
14f9c5c9 9049
aa715135 9050 return result;
4c4b4cd2
PH
9051}
9052
9053static struct value *
3cb382c9 9054value_pos_atr (struct type *type, struct value *arg)
4c4b4cd2 9055{
3cb382c9 9056 return value_from_longest (type, pos_atr (arg));
14f9c5c9
AS
9057}
9058
4c4b4cd2 9059/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 9060
d2e4a39e
AS
9061static struct value *
9062value_val_atr (struct type *type, struct value *arg)
14f9c5c9 9063{
d2e4a39e 9064 if (!discrete_type_p (type))
323e0a4a 9065 error (_("'VAL only defined on discrete types"));
df407dfe 9066 if (!integer_type_p (value_type (arg)))
323e0a4a 9067 error (_("'VAL requires integral argument"));
14f9c5c9
AS
9068
9069 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9070 {
9071 long pos = value_as_long (arg);
5b4ee69b 9072
14f9c5c9 9073 if (pos < 0 || pos >= TYPE_NFIELDS (type))
323e0a4a 9074 error (_("argument to 'VAL out of range"));
14e75d8e 9075 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
14f9c5c9
AS
9076 }
9077 else
9078 return value_from_longest (type, value_as_long (arg));
9079}
14f9c5c9 9080\f
d2e4a39e 9081
4c4b4cd2 9082 /* Evaluation */
14f9c5c9 9083
4c4b4cd2
PH
9084/* True if TYPE appears to be an Ada character type.
9085 [At the moment, this is true only for Character and Wide_Character;
9086 It is a heuristic test that could stand improvement]. */
14f9c5c9 9087
d2e4a39e
AS
9088int
9089ada_is_character_type (struct type *type)
14f9c5c9 9090{
7b9f71f2
JB
9091 const char *name;
9092
9093 /* If the type code says it's a character, then assume it really is,
9094 and don't check any further. */
9095 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9096 return 1;
9097
9098 /* Otherwise, assume it's a character type iff it is a discrete type
9099 with a known character type name. */
9100 name = ada_type_name (type);
9101 return (name != NULL
9102 && (TYPE_CODE (type) == TYPE_CODE_INT
9103 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9104 && (strcmp (name, "character") == 0
9105 || strcmp (name, "wide_character") == 0
5a517ebd 9106 || strcmp (name, "wide_wide_character") == 0
7b9f71f2 9107 || strcmp (name, "unsigned char") == 0));
14f9c5c9
AS
9108}
9109
4c4b4cd2 9110/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
9111
9112int
ebf56fd3 9113ada_is_string_type (struct type *type)
14f9c5c9 9114{
61ee279c 9115 type = ada_check_typedef (type);
d2e4a39e 9116 if (type != NULL
14f9c5c9 9117 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
9118 && (ada_is_simple_array_type (type)
9119 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
9120 && ada_array_arity (type) == 1)
9121 {
9122 struct type *elttype = ada_array_element_type (type, 1);
9123
9124 return ada_is_character_type (elttype);
9125 }
d2e4a39e 9126 else
14f9c5c9
AS
9127 return 0;
9128}
9129
5bf03f13
JB
9130/* The compiler sometimes provides a parallel XVS type for a given
9131 PAD type. Normally, it is safe to follow the PAD type directly,
9132 but older versions of the compiler have a bug that causes the offset
9133 of its "F" field to be wrong. Following that field in that case
9134 would lead to incorrect results, but this can be worked around
9135 by ignoring the PAD type and using the associated XVS type instead.
9136
9137 Set to True if the debugger should trust the contents of PAD types.
9138 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9139static int trust_pad_over_xvs = 1;
14f9c5c9
AS
9140
9141/* True if TYPE is a struct type introduced by the compiler to force the
9142 alignment of a value. Such types have a single field with a
4c4b4cd2 9143 distinctive name. */
14f9c5c9
AS
9144
9145int
ebf56fd3 9146ada_is_aligner_type (struct type *type)
14f9c5c9 9147{
61ee279c 9148 type = ada_check_typedef (type);
714e53ab 9149
5bf03f13 9150 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
714e53ab
PH
9151 return 0;
9152
14f9c5c9 9153 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
9154 && TYPE_NFIELDS (type) == 1
9155 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
9156}
9157
9158/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 9159 the parallel type. */
14f9c5c9 9160
d2e4a39e
AS
9161struct type *
9162ada_get_base_type (struct type *raw_type)
14f9c5c9 9163{
d2e4a39e
AS
9164 struct type *real_type_namer;
9165 struct type *raw_real_type;
14f9c5c9
AS
9166
9167 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9168 return raw_type;
9169
284614f0
JB
9170 if (ada_is_aligner_type (raw_type))
9171 /* The encoding specifies that we should always use the aligner type.
9172 So, even if this aligner type has an associated XVS type, we should
9173 simply ignore it.
9174
9175 According to the compiler gurus, an XVS type parallel to an aligner
9176 type may exist because of a stabs limitation. In stabs, aligner
9177 types are empty because the field has a variable-sized type, and
9178 thus cannot actually be used as an aligner type. As a result,
9179 we need the associated parallel XVS type to decode the type.
9180 Since the policy in the compiler is to not change the internal
9181 representation based on the debugging info format, we sometimes
9182 end up having a redundant XVS type parallel to the aligner type. */
9183 return raw_type;
9184
14f9c5c9 9185 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 9186 if (real_type_namer == NULL
14f9c5c9
AS
9187 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9188 || TYPE_NFIELDS (real_type_namer) != 1)
9189 return raw_type;
9190
f80d3ff2
JB
9191 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9192 {
9193 /* This is an older encoding form where the base type needs to be
9194 looked up by name. We prefer the newer enconding because it is
9195 more efficient. */
9196 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9197 if (raw_real_type == NULL)
9198 return raw_type;
9199 else
9200 return raw_real_type;
9201 }
9202
9203 /* The field in our XVS type is a reference to the base type. */
9204 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
d2e4a39e 9205}
14f9c5c9 9206
4c4b4cd2 9207/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 9208
d2e4a39e
AS
9209struct type *
9210ada_aligned_type (struct type *type)
14f9c5c9
AS
9211{
9212 if (ada_is_aligner_type (type))
9213 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9214 else
9215 return ada_get_base_type (type);
9216}
9217
9218
9219/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 9220 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 9221
fc1a4b47
AC
9222const gdb_byte *
9223ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
14f9c5c9 9224{
d2e4a39e 9225 if (ada_is_aligner_type (type))
14f9c5c9 9226 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
9227 valaddr +
9228 TYPE_FIELD_BITPOS (type,
9229 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
9230 else
9231 return valaddr;
9232}
9233
4c4b4cd2
PH
9234
9235
14f9c5c9 9236/* The printed representation of an enumeration literal with encoded
4c4b4cd2 9237 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
9238const char *
9239ada_enum_name (const char *name)
14f9c5c9 9240{
4c4b4cd2
PH
9241 static char *result;
9242 static size_t result_len = 0;
d2e4a39e 9243 char *tmp;
14f9c5c9 9244
4c4b4cd2
PH
9245 /* First, unqualify the enumeration name:
9246 1. Search for the last '.' character. If we find one, then skip
177b42fe 9247 all the preceding characters, the unqualified name starts
76a01679 9248 right after that dot.
4c4b4cd2 9249 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
9250 translates dots into "__". Search forward for double underscores,
9251 but stop searching when we hit an overloading suffix, which is
9252 of the form "__" followed by digits. */
4c4b4cd2 9253
c3e5cd34
PH
9254 tmp = strrchr (name, '.');
9255 if (tmp != NULL)
4c4b4cd2
PH
9256 name = tmp + 1;
9257 else
14f9c5c9 9258 {
4c4b4cd2
PH
9259 while ((tmp = strstr (name, "__")) != NULL)
9260 {
9261 if (isdigit (tmp[2]))
9262 break;
9263 else
9264 name = tmp + 2;
9265 }
14f9c5c9
AS
9266 }
9267
9268 if (name[0] == 'Q')
9269 {
14f9c5c9 9270 int v;
5b4ee69b 9271
14f9c5c9 9272 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
9273 {
9274 if (sscanf (name + 2, "%x", &v) != 1)
9275 return name;
9276 }
14f9c5c9 9277 else
4c4b4cd2 9278 return name;
14f9c5c9 9279
4c4b4cd2 9280 GROW_VECT (result, result_len, 16);
14f9c5c9 9281 if (isascii (v) && isprint (v))
88c15c34 9282 xsnprintf (result, result_len, "'%c'", v);
14f9c5c9 9283 else if (name[1] == 'U')
88c15c34 9284 xsnprintf (result, result_len, "[\"%02x\"]", v);
14f9c5c9 9285 else
88c15c34 9286 xsnprintf (result, result_len, "[\"%04x\"]", v);
14f9c5c9
AS
9287
9288 return result;
9289 }
d2e4a39e 9290 else
4c4b4cd2 9291 {
c3e5cd34
PH
9292 tmp = strstr (name, "__");
9293 if (tmp == NULL)
9294 tmp = strstr (name, "$");
9295 if (tmp != NULL)
4c4b4cd2
PH
9296 {
9297 GROW_VECT (result, result_len, tmp - name + 1);
9298 strncpy (result, name, tmp - name);
9299 result[tmp - name] = '\0';
9300 return result;
9301 }
9302
9303 return name;
9304 }
14f9c5c9
AS
9305}
9306
14f9c5c9
AS
9307/* Evaluate the subexpression of EXP starting at *POS as for
9308 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 9309 expression. */
14f9c5c9 9310
d2e4a39e
AS
9311static struct value *
9312evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 9313{
4b27a620 9314 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
14f9c5c9
AS
9315}
9316
9317/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 9318 value it wraps. */
14f9c5c9 9319
d2e4a39e
AS
9320static struct value *
9321unwrap_value (struct value *val)
14f9c5c9 9322{
df407dfe 9323 struct type *type = ada_check_typedef (value_type (val));
5b4ee69b 9324
14f9c5c9
AS
9325 if (ada_is_aligner_type (type))
9326 {
de4d072f 9327 struct value *v = ada_value_struct_elt (val, "F", 0);
df407dfe 9328 struct type *val_type = ada_check_typedef (value_type (v));
5b4ee69b 9329
14f9c5c9 9330 if (ada_type_name (val_type) == NULL)
4c4b4cd2 9331 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
9332
9333 return unwrap_value (v);
9334 }
d2e4a39e 9335 else
14f9c5c9 9336 {
d2e4a39e 9337 struct type *raw_real_type =
61ee279c 9338 ada_check_typedef (ada_get_base_type (type));
d2e4a39e 9339
5bf03f13
JB
9340 /* If there is no parallel XVS or XVE type, then the value is
9341 already unwrapped. Return it without further modification. */
9342 if ((type == raw_real_type)
9343 && ada_find_parallel_type (type, "___XVE") == NULL)
9344 return val;
14f9c5c9 9345
d2e4a39e 9346 return
4c4b4cd2
PH
9347 coerce_unspec_val_to_type
9348 (val, ada_to_fixed_type (raw_real_type, 0,
42ae5230 9349 value_address (val),
1ed6ede0 9350 NULL, 1));
14f9c5c9
AS
9351 }
9352}
d2e4a39e
AS
9353
9354static struct value *
9355cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
9356{
9357 LONGEST val;
9358
df407dfe 9359 if (type == value_type (arg))
14f9c5c9 9360 return arg;
df407dfe 9361 else if (ada_is_fixed_point_type (value_type (arg)))
d2e4a39e 9362 val = ada_float_to_fixed (type,
df407dfe 9363 ada_fixed_to_float (value_type (arg),
4c4b4cd2 9364 value_as_long (arg)));
d2e4a39e 9365 else
14f9c5c9 9366 {
a53b7a21 9367 DOUBLEST argd = value_as_double (arg);
5b4ee69b 9368
14f9c5c9
AS
9369 val = ada_float_to_fixed (type, argd);
9370 }
9371
9372 return value_from_longest (type, val);
9373}
9374
d2e4a39e 9375static struct value *
a53b7a21 9376cast_from_fixed (struct type *type, struct value *arg)
14f9c5c9 9377{
df407dfe 9378 DOUBLEST val = ada_fixed_to_float (value_type (arg),
4c4b4cd2 9379 value_as_long (arg));
5b4ee69b 9380
a53b7a21 9381 return value_from_double (type, val);
14f9c5c9
AS
9382}
9383
d99dcf51
JB
9384/* Given two array types T1 and T2, return nonzero iff both arrays
9385 contain the same number of elements. */
9386
9387static int
9388ada_same_array_size_p (struct type *t1, struct type *t2)
9389{
9390 LONGEST lo1, hi1, lo2, hi2;
9391
9392 /* Get the array bounds in order to verify that the size of
9393 the two arrays match. */
9394 if (!get_array_bounds (t1, &lo1, &hi1)
9395 || !get_array_bounds (t2, &lo2, &hi2))
9396 error (_("unable to determine array bounds"));
9397
9398 /* To make things easier for size comparison, normalize a bit
9399 the case of empty arrays by making sure that the difference
9400 between upper bound and lower bound is always -1. */
9401 if (lo1 > hi1)
9402 hi1 = lo1 - 1;
9403 if (lo2 > hi2)
9404 hi2 = lo2 - 1;
9405
9406 return (hi1 - lo1 == hi2 - lo2);
9407}
9408
9409/* Assuming that VAL is an array of integrals, and TYPE represents
9410 an array with the same number of elements, but with wider integral
9411 elements, return an array "casted" to TYPE. In practice, this
9412 means that the returned array is built by casting each element
9413 of the original array into TYPE's (wider) element type. */
9414
9415static struct value *
9416ada_promote_array_of_integrals (struct type *type, struct value *val)
9417{
9418 struct type *elt_type = TYPE_TARGET_TYPE (type);
9419 LONGEST lo, hi;
9420 struct value *res;
9421 LONGEST i;
9422
9423 /* Verify that both val and type are arrays of scalars, and
9424 that the size of val's elements is smaller than the size
9425 of type's element. */
9426 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9427 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9428 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9429 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9430 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9431 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9432
9433 if (!get_array_bounds (type, &lo, &hi))
9434 error (_("unable to determine array bounds"));
9435
9436 res = allocate_value (type);
9437
9438 /* Promote each array element. */
9439 for (i = 0; i < hi - lo + 1; i++)
9440 {
9441 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9442
9443 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9444 value_contents_all (elt), TYPE_LENGTH (elt_type));
9445 }
9446
9447 return res;
9448}
9449
4c4b4cd2
PH
9450/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9451 return the converted value. */
9452
d2e4a39e
AS
9453static struct value *
9454coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 9455{
df407dfe 9456 struct type *type2 = value_type (val);
5b4ee69b 9457
14f9c5c9
AS
9458 if (type == type2)
9459 return val;
9460
61ee279c
PH
9461 type2 = ada_check_typedef (type2);
9462 type = ada_check_typedef (type);
14f9c5c9 9463
d2e4a39e
AS
9464 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9465 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
9466 {
9467 val = ada_value_ind (val);
df407dfe 9468 type2 = value_type (val);
14f9c5c9
AS
9469 }
9470
d2e4a39e 9471 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
9472 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9473 {
d99dcf51
JB
9474 if (!ada_same_array_size_p (type, type2))
9475 error (_("cannot assign arrays of different length"));
9476
9477 if (is_integral_type (TYPE_TARGET_TYPE (type))
9478 && is_integral_type (TYPE_TARGET_TYPE (type2))
9479 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9480 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9481 {
9482 /* Allow implicit promotion of the array elements to
9483 a wider type. */
9484 return ada_promote_array_of_integrals (type, val);
9485 }
9486
9487 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9488 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
323e0a4a 9489 error (_("Incompatible types in assignment"));
04624583 9490 deprecated_set_value_type (val, type);
14f9c5c9 9491 }
d2e4a39e 9492 return val;
14f9c5c9
AS
9493}
9494
4c4b4cd2
PH
9495static struct value *
9496ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9497{
9498 struct value *val;
9499 struct type *type1, *type2;
9500 LONGEST v, v1, v2;
9501
994b9211
AC
9502 arg1 = coerce_ref (arg1);
9503 arg2 = coerce_ref (arg2);
18af8284
JB
9504 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9505 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
4c4b4cd2 9506
76a01679
JB
9507 if (TYPE_CODE (type1) != TYPE_CODE_INT
9508 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
9509 return value_binop (arg1, arg2, op);
9510
76a01679 9511 switch (op)
4c4b4cd2
PH
9512 {
9513 case BINOP_MOD:
9514 case BINOP_DIV:
9515 case BINOP_REM:
9516 break;
9517 default:
9518 return value_binop (arg1, arg2, op);
9519 }
9520
9521 v2 = value_as_long (arg2);
9522 if (v2 == 0)
323e0a4a 9523 error (_("second operand of %s must not be zero."), op_string (op));
4c4b4cd2
PH
9524
9525 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9526 return value_binop (arg1, arg2, op);
9527
9528 v1 = value_as_long (arg1);
9529 switch (op)
9530 {
9531 case BINOP_DIV:
9532 v = v1 / v2;
76a01679
JB
9533 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9534 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
9535 break;
9536 case BINOP_REM:
9537 v = v1 % v2;
76a01679
JB
9538 if (v * v1 < 0)
9539 v -= v2;
4c4b4cd2
PH
9540 break;
9541 default:
9542 /* Should not reach this point. */
9543 v = 0;
9544 }
9545
9546 val = allocate_value (type1);
990a07ab 9547 store_unsigned_integer (value_contents_raw (val),
e17a4113
UW
9548 TYPE_LENGTH (value_type (val)),
9549 gdbarch_byte_order (get_type_arch (type1)), v);
4c4b4cd2
PH
9550 return val;
9551}
9552
9553static int
9554ada_value_equal (struct value *arg1, struct value *arg2)
9555{
df407dfe
AC
9556 if (ada_is_direct_array_type (value_type (arg1))
9557 || ada_is_direct_array_type (value_type (arg2)))
4c4b4cd2 9558 {
f58b38bf
JB
9559 /* Automatically dereference any array reference before
9560 we attempt to perform the comparison. */
9561 arg1 = ada_coerce_ref (arg1);
9562 arg2 = ada_coerce_ref (arg2);
9563
4c4b4cd2
PH
9564 arg1 = ada_coerce_to_simple_array (arg1);
9565 arg2 = ada_coerce_to_simple_array (arg2);
df407dfe
AC
9566 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9567 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
323e0a4a 9568 error (_("Attempt to compare array with non-array"));
4c4b4cd2 9569 /* FIXME: The following works only for types whose
76a01679
JB
9570 representations use all bits (no padding or undefined bits)
9571 and do not have user-defined equality. */
9572 return
df407dfe 9573 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
0fd88904 9574 && memcmp (value_contents (arg1), value_contents (arg2),
df407dfe 9575 TYPE_LENGTH (value_type (arg1))) == 0;
4c4b4cd2
PH
9576 }
9577 return value_equal (arg1, arg2);
9578}
9579
52ce6436
PH
9580/* Total number of component associations in the aggregate starting at
9581 index PC in EXP. Assumes that index PC is the start of an
0963b4bd 9582 OP_AGGREGATE. */
52ce6436
PH
9583
9584static int
9585num_component_specs (struct expression *exp, int pc)
9586{
9587 int n, m, i;
5b4ee69b 9588
52ce6436
PH
9589 m = exp->elts[pc + 1].longconst;
9590 pc += 3;
9591 n = 0;
9592 for (i = 0; i < m; i += 1)
9593 {
9594 switch (exp->elts[pc].opcode)
9595 {
9596 default:
9597 n += 1;
9598 break;
9599 case OP_CHOICES:
9600 n += exp->elts[pc + 1].longconst;
9601 break;
9602 }
9603 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9604 }
9605 return n;
9606}
9607
9608/* Assign the result of evaluating EXP starting at *POS to the INDEXth
9609 component of LHS (a simple array or a record), updating *POS past
9610 the expression, assuming that LHS is contained in CONTAINER. Does
9611 not modify the inferior's memory, nor does it modify LHS (unless
9612 LHS == CONTAINER). */
9613
9614static void
9615assign_component (struct value *container, struct value *lhs, LONGEST index,
9616 struct expression *exp, int *pos)
9617{
9618 struct value *mark = value_mark ();
9619 struct value *elt;
5b4ee69b 9620
52ce6436
PH
9621 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9622 {
22601c15
UW
9623 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9624 struct value *index_val = value_from_longest (index_type, index);
5b4ee69b 9625
52ce6436
PH
9626 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9627 }
9628 else
9629 {
9630 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
c48db5ca 9631 elt = ada_to_fixed_value (elt);
52ce6436
PH
9632 }
9633
9634 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9635 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9636 else
9637 value_assign_to_component (container, elt,
9638 ada_evaluate_subexp (NULL, exp, pos,
9639 EVAL_NORMAL));
9640
9641 value_free_to_mark (mark);
9642}
9643
9644/* Assuming that LHS represents an lvalue having a record or array
9645 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9646 of that aggregate's value to LHS, advancing *POS past the
9647 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9648 lvalue containing LHS (possibly LHS itself). Does not modify
9649 the inferior's memory, nor does it modify the contents of
0963b4bd 9650 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
52ce6436
PH
9651
9652static struct value *
9653assign_aggregate (struct value *container,
9654 struct value *lhs, struct expression *exp,
9655 int *pos, enum noside noside)
9656{
9657 struct type *lhs_type;
9658 int n = exp->elts[*pos+1].longconst;
9659 LONGEST low_index, high_index;
9660 int num_specs;
9661 LONGEST *indices;
9662 int max_indices, num_indices;
52ce6436 9663 int i;
52ce6436
PH
9664
9665 *pos += 3;
9666 if (noside != EVAL_NORMAL)
9667 {
52ce6436
PH
9668 for (i = 0; i < n; i += 1)
9669 ada_evaluate_subexp (NULL, exp, pos, noside);
9670 return container;
9671 }
9672
9673 container = ada_coerce_ref (container);
9674 if (ada_is_direct_array_type (value_type (container)))
9675 container = ada_coerce_to_simple_array (container);
9676 lhs = ada_coerce_ref (lhs);
9677 if (!deprecated_value_modifiable (lhs))
9678 error (_("Left operand of assignment is not a modifiable lvalue."));
9679
9680 lhs_type = value_type (lhs);
9681 if (ada_is_direct_array_type (lhs_type))
9682 {
9683 lhs = ada_coerce_to_simple_array (lhs);
9684 lhs_type = value_type (lhs);
9685 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9686 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
52ce6436
PH
9687 }
9688 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9689 {
9690 low_index = 0;
9691 high_index = num_visible_fields (lhs_type) - 1;
52ce6436
PH
9692 }
9693 else
9694 error (_("Left-hand side must be array or record."));
9695
9696 num_specs = num_component_specs (exp, *pos - 3);
9697 max_indices = 4 * num_specs + 4;
9698 indices = alloca (max_indices * sizeof (indices[0]));
9699 indices[0] = indices[1] = low_index - 1;
9700 indices[2] = indices[3] = high_index + 1;
9701 num_indices = 4;
9702
9703 for (i = 0; i < n; i += 1)
9704 {
9705 switch (exp->elts[*pos].opcode)
9706 {
1fbf5ada
JB
9707 case OP_CHOICES:
9708 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9709 &num_indices, max_indices,
9710 low_index, high_index);
9711 break;
9712 case OP_POSITIONAL:
9713 aggregate_assign_positional (container, lhs, exp, pos, indices,
52ce6436
PH
9714 &num_indices, max_indices,
9715 low_index, high_index);
1fbf5ada
JB
9716 break;
9717 case OP_OTHERS:
9718 if (i != n-1)
9719 error (_("Misplaced 'others' clause"));
9720 aggregate_assign_others (container, lhs, exp, pos, indices,
9721 num_indices, low_index, high_index);
9722 break;
9723 default:
9724 error (_("Internal error: bad aggregate clause"));
52ce6436
PH
9725 }
9726 }
9727
9728 return container;
9729}
9730
9731/* Assign into the component of LHS indexed by the OP_POSITIONAL
9732 construct at *POS, updating *POS past the construct, given that
9733 the positions are relative to lower bound LOW, where HIGH is the
9734 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9735 updating *NUM_INDICES as needed. CONTAINER is as for
0963b4bd 9736 assign_aggregate. */
52ce6436
PH
9737static void
9738aggregate_assign_positional (struct value *container,
9739 struct value *lhs, struct expression *exp,
9740 int *pos, LONGEST *indices, int *num_indices,
9741 int max_indices, LONGEST low, LONGEST high)
9742{
9743 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9744
9745 if (ind - 1 == high)
e1d5a0d2 9746 warning (_("Extra components in aggregate ignored."));
52ce6436
PH
9747 if (ind <= high)
9748 {
9749 add_component_interval (ind, ind, indices, num_indices, max_indices);
9750 *pos += 3;
9751 assign_component (container, lhs, ind, exp, pos);
9752 }
9753 else
9754 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9755}
9756
9757/* Assign into the components of LHS indexed by the OP_CHOICES
9758 construct at *POS, updating *POS past the construct, given that
9759 the allowable indices are LOW..HIGH. Record the indices assigned
9760 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
0963b4bd 9761 needed. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9762static void
9763aggregate_assign_from_choices (struct value *container,
9764 struct value *lhs, struct expression *exp,
9765 int *pos, LONGEST *indices, int *num_indices,
9766 int max_indices, LONGEST low, LONGEST high)
9767{
9768 int j;
9769 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9770 int choice_pos, expr_pc;
9771 int is_array = ada_is_direct_array_type (value_type (lhs));
9772
9773 choice_pos = *pos += 3;
9774
9775 for (j = 0; j < n_choices; j += 1)
9776 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9777 expr_pc = *pos;
9778 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9779
9780 for (j = 0; j < n_choices; j += 1)
9781 {
9782 LONGEST lower, upper;
9783 enum exp_opcode op = exp->elts[choice_pos].opcode;
5b4ee69b 9784
52ce6436
PH
9785 if (op == OP_DISCRETE_RANGE)
9786 {
9787 choice_pos += 1;
9788 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9789 EVAL_NORMAL));
9790 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9791 EVAL_NORMAL));
9792 }
9793 else if (is_array)
9794 {
9795 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9796 EVAL_NORMAL));
9797 upper = lower;
9798 }
9799 else
9800 {
9801 int ind;
0d5cff50 9802 const char *name;
5b4ee69b 9803
52ce6436
PH
9804 switch (op)
9805 {
9806 case OP_NAME:
9807 name = &exp->elts[choice_pos + 2].string;
9808 break;
9809 case OP_VAR_VALUE:
9810 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9811 break;
9812 default:
9813 error (_("Invalid record component association."));
9814 }
9815 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9816 ind = 0;
9817 if (! find_struct_field (name, value_type (lhs), 0,
9818 NULL, NULL, NULL, NULL, &ind))
9819 error (_("Unknown component name: %s."), name);
9820 lower = upper = ind;
9821 }
9822
9823 if (lower <= upper && (lower < low || upper > high))
9824 error (_("Index in component association out of bounds."));
9825
9826 add_component_interval (lower, upper, indices, num_indices,
9827 max_indices);
9828 while (lower <= upper)
9829 {
9830 int pos1;
5b4ee69b 9831
52ce6436
PH
9832 pos1 = expr_pc;
9833 assign_component (container, lhs, lower, exp, &pos1);
9834 lower += 1;
9835 }
9836 }
9837}
9838
9839/* Assign the value of the expression in the OP_OTHERS construct in
9840 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9841 have not been previously assigned. The index intervals already assigned
9842 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
0963b4bd 9843 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
52ce6436
PH
9844static void
9845aggregate_assign_others (struct value *container,
9846 struct value *lhs, struct expression *exp,
9847 int *pos, LONGEST *indices, int num_indices,
9848 LONGEST low, LONGEST high)
9849{
9850 int i;
5ce64950 9851 int expr_pc = *pos + 1;
52ce6436
PH
9852
9853 for (i = 0; i < num_indices - 2; i += 2)
9854 {
9855 LONGEST ind;
5b4ee69b 9856
52ce6436
PH
9857 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9858 {
5ce64950 9859 int localpos;
5b4ee69b 9860
5ce64950
MS
9861 localpos = expr_pc;
9862 assign_component (container, lhs, ind, exp, &localpos);
52ce6436
PH
9863 }
9864 }
9865 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9866}
9867
9868/* Add the interval [LOW .. HIGH] to the sorted set of intervals
9869 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9870 modifying *SIZE as needed. It is an error if *SIZE exceeds
9871 MAX_SIZE. The resulting intervals do not overlap. */
9872static void
9873add_component_interval (LONGEST low, LONGEST high,
9874 LONGEST* indices, int *size, int max_size)
9875{
9876 int i, j;
5b4ee69b 9877
52ce6436
PH
9878 for (i = 0; i < *size; i += 2) {
9879 if (high >= indices[i] && low <= indices[i + 1])
9880 {
9881 int kh;
5b4ee69b 9882
52ce6436
PH
9883 for (kh = i + 2; kh < *size; kh += 2)
9884 if (high < indices[kh])
9885 break;
9886 if (low < indices[i])
9887 indices[i] = low;
9888 indices[i + 1] = indices[kh - 1];
9889 if (high > indices[i + 1])
9890 indices[i + 1] = high;
9891 memcpy (indices + i + 2, indices + kh, *size - kh);
9892 *size -= kh - i - 2;
9893 return;
9894 }
9895 else if (high < indices[i])
9896 break;
9897 }
9898
9899 if (*size == max_size)
9900 error (_("Internal error: miscounted aggregate components."));
9901 *size += 2;
9902 for (j = *size-1; j >= i+2; j -= 1)
9903 indices[j] = indices[j - 2];
9904 indices[i] = low;
9905 indices[i + 1] = high;
9906}
9907
6e48bd2c
JB
9908/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9909 is different. */
9910
9911static struct value *
9912ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9913{
9914 if (type == ada_check_typedef (value_type (arg2)))
9915 return arg2;
9916
9917 if (ada_is_fixed_point_type (type))
9918 return (cast_to_fixed (type, arg2));
9919
9920 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 9921 return cast_from_fixed (type, arg2);
6e48bd2c
JB
9922
9923 return value_cast (type, arg2);
9924}
9925
284614f0
JB
9926/* Evaluating Ada expressions, and printing their result.
9927 ------------------------------------------------------
9928
21649b50
JB
9929 1. Introduction:
9930 ----------------
9931
284614f0
JB
9932 We usually evaluate an Ada expression in order to print its value.
9933 We also evaluate an expression in order to print its type, which
9934 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9935 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9936 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9937 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9938 similar.
9939
9940 Evaluating expressions is a little more complicated for Ada entities
9941 than it is for entities in languages such as C. The main reason for
9942 this is that Ada provides types whose definition might be dynamic.
9943 One example of such types is variant records. Or another example
9944 would be an array whose bounds can only be known at run time.
9945
9946 The following description is a general guide as to what should be
9947 done (and what should NOT be done) in order to evaluate an expression
9948 involving such types, and when. This does not cover how the semantic
9949 information is encoded by GNAT as this is covered separatly. For the
9950 document used as the reference for the GNAT encoding, see exp_dbug.ads
9951 in the GNAT sources.
9952
9953 Ideally, we should embed each part of this description next to its
9954 associated code. Unfortunately, the amount of code is so vast right
9955 now that it's hard to see whether the code handling a particular
9956 situation might be duplicated or not. One day, when the code is
9957 cleaned up, this guide might become redundant with the comments
9958 inserted in the code, and we might want to remove it.
9959
21649b50
JB
9960 2. ``Fixing'' an Entity, the Simple Case:
9961 -----------------------------------------
9962
284614f0
JB
9963 When evaluating Ada expressions, the tricky issue is that they may
9964 reference entities whose type contents and size are not statically
9965 known. Consider for instance a variant record:
9966
9967 type Rec (Empty : Boolean := True) is record
9968 case Empty is
9969 when True => null;
9970 when False => Value : Integer;
9971 end case;
9972 end record;
9973 Yes : Rec := (Empty => False, Value => 1);
9974 No : Rec := (empty => True);
9975
9976 The size and contents of that record depends on the value of the
9977 descriminant (Rec.Empty). At this point, neither the debugging
9978 information nor the associated type structure in GDB are able to
9979 express such dynamic types. So what the debugger does is to create
9980 "fixed" versions of the type that applies to the specific object.
9981 We also informally refer to this opperation as "fixing" an object,
9982 which means creating its associated fixed type.
9983
9984 Example: when printing the value of variable "Yes" above, its fixed
9985 type would look like this:
9986
9987 type Rec is record
9988 Empty : Boolean;
9989 Value : Integer;
9990 end record;
9991
9992 On the other hand, if we printed the value of "No", its fixed type
9993 would become:
9994
9995 type Rec is record
9996 Empty : Boolean;
9997 end record;
9998
9999 Things become a little more complicated when trying to fix an entity
10000 with a dynamic type that directly contains another dynamic type,
10001 such as an array of variant records, for instance. There are
10002 two possible cases: Arrays, and records.
10003
21649b50
JB
10004 3. ``Fixing'' Arrays:
10005 ---------------------
10006
10007 The type structure in GDB describes an array in terms of its bounds,
10008 and the type of its elements. By design, all elements in the array
10009 have the same type and we cannot represent an array of variant elements
10010 using the current type structure in GDB. When fixing an array,
10011 we cannot fix the array element, as we would potentially need one
10012 fixed type per element of the array. As a result, the best we can do
10013 when fixing an array is to produce an array whose bounds and size
10014 are correct (allowing us to read it from memory), but without having
10015 touched its element type. Fixing each element will be done later,
10016 when (if) necessary.
10017
10018 Arrays are a little simpler to handle than records, because the same
10019 amount of memory is allocated for each element of the array, even if
1b536f04 10020 the amount of space actually used by each element differs from element
21649b50 10021 to element. Consider for instance the following array of type Rec:
284614f0
JB
10022
10023 type Rec_Array is array (1 .. 2) of Rec;
10024
1b536f04
JB
10025 The actual amount of memory occupied by each element might be different
10026 from element to element, depending on the value of their discriminant.
21649b50 10027 But the amount of space reserved for each element in the array remains
1b536f04 10028 fixed regardless. So we simply need to compute that size using
21649b50
JB
10029 the debugging information available, from which we can then determine
10030 the array size (we multiply the number of elements of the array by
10031 the size of each element).
10032
10033 The simplest case is when we have an array of a constrained element
10034 type. For instance, consider the following type declarations:
10035
10036 type Bounded_String (Max_Size : Integer) is
10037 Length : Integer;
10038 Buffer : String (1 .. Max_Size);
10039 end record;
10040 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10041
10042 In this case, the compiler describes the array as an array of
10043 variable-size elements (identified by its XVS suffix) for which
10044 the size can be read in the parallel XVZ variable.
10045
10046 In the case of an array of an unconstrained element type, the compiler
10047 wraps the array element inside a private PAD type. This type should not
10048 be shown to the user, and must be "unwrap"'ed before printing. Note
284614f0
JB
10049 that we also use the adjective "aligner" in our code to designate
10050 these wrapper types.
10051
1b536f04 10052 In some cases, the size allocated for each element is statically
21649b50
JB
10053 known. In that case, the PAD type already has the correct size,
10054 and the array element should remain unfixed.
10055
10056 But there are cases when this size is not statically known.
10057 For instance, assuming that "Five" is an integer variable:
284614f0
JB
10058
10059 type Dynamic is array (1 .. Five) of Integer;
10060 type Wrapper (Has_Length : Boolean := False) is record
10061 Data : Dynamic;
10062 case Has_Length is
10063 when True => Length : Integer;
10064 when False => null;
10065 end case;
10066 end record;
10067 type Wrapper_Array is array (1 .. 2) of Wrapper;
10068
10069 Hello : Wrapper_Array := (others => (Has_Length => True,
10070 Data => (others => 17),
10071 Length => 1));
10072
10073
10074 The debugging info would describe variable Hello as being an
10075 array of a PAD type. The size of that PAD type is not statically
10076 known, but can be determined using a parallel XVZ variable.
10077 In that case, a copy of the PAD type with the correct size should
10078 be used for the fixed array.
10079
21649b50
JB
10080 3. ``Fixing'' record type objects:
10081 ----------------------------------
10082
10083 Things are slightly different from arrays in the case of dynamic
284614f0
JB
10084 record types. In this case, in order to compute the associated
10085 fixed type, we need to determine the size and offset of each of
10086 its components. This, in turn, requires us to compute the fixed
10087 type of each of these components.
10088
10089 Consider for instance the example:
10090
10091 type Bounded_String (Max_Size : Natural) is record
10092 Str : String (1 .. Max_Size);
10093 Length : Natural;
10094 end record;
10095 My_String : Bounded_String (Max_Size => 10);
10096
10097 In that case, the position of field "Length" depends on the size
10098 of field Str, which itself depends on the value of the Max_Size
21649b50 10099 discriminant. In order to fix the type of variable My_String,
284614f0
JB
10100 we need to fix the type of field Str. Therefore, fixing a variant
10101 record requires us to fix each of its components.
10102
10103 However, if a component does not have a dynamic size, the component
10104 should not be fixed. In particular, fields that use a PAD type
10105 should not fixed. Here is an example where this might happen
10106 (assuming type Rec above):
10107
10108 type Container (Big : Boolean) is record
10109 First : Rec;
10110 After : Integer;
10111 case Big is
10112 when True => Another : Integer;
10113 when False => null;
10114 end case;
10115 end record;
10116 My_Container : Container := (Big => False,
10117 First => (Empty => True),
10118 After => 42);
10119
10120 In that example, the compiler creates a PAD type for component First,
10121 whose size is constant, and then positions the component After just
10122 right after it. The offset of component After is therefore constant
10123 in this case.
10124
10125 The debugger computes the position of each field based on an algorithm
10126 that uses, among other things, the actual position and size of the field
21649b50
JB
10127 preceding it. Let's now imagine that the user is trying to print
10128 the value of My_Container. If the type fixing was recursive, we would
284614f0
JB
10129 end up computing the offset of field After based on the size of the
10130 fixed version of field First. And since in our example First has
10131 only one actual field, the size of the fixed type is actually smaller
10132 than the amount of space allocated to that field, and thus we would
10133 compute the wrong offset of field After.
10134
21649b50
JB
10135 To make things more complicated, we need to watch out for dynamic
10136 components of variant records (identified by the ___XVL suffix in
10137 the component name). Even if the target type is a PAD type, the size
10138 of that type might not be statically known. So the PAD type needs
10139 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10140 we might end up with the wrong size for our component. This can be
10141 observed with the following type declarations:
284614f0
JB
10142
10143 type Octal is new Integer range 0 .. 7;
10144 type Octal_Array is array (Positive range <>) of Octal;
10145 pragma Pack (Octal_Array);
10146
10147 type Octal_Buffer (Size : Positive) is record
10148 Buffer : Octal_Array (1 .. Size);
10149 Length : Integer;
10150 end record;
10151
10152 In that case, Buffer is a PAD type whose size is unset and needs
10153 to be computed by fixing the unwrapped type.
10154
21649b50
JB
10155 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10156 ----------------------------------------------------------
10157
10158 Lastly, when should the sub-elements of an entity that remained unfixed
284614f0
JB
10159 thus far, be actually fixed?
10160
10161 The answer is: Only when referencing that element. For instance
10162 when selecting one component of a record, this specific component
10163 should be fixed at that point in time. Or when printing the value
10164 of a record, each component should be fixed before its value gets
10165 printed. Similarly for arrays, the element of the array should be
10166 fixed when printing each element of the array, or when extracting
10167 one element out of that array. On the other hand, fixing should
10168 not be performed on the elements when taking a slice of an array!
10169
10170 Note that one of the side-effects of miscomputing the offset and
10171 size of each field is that we end up also miscomputing the size
10172 of the containing type. This can have adverse results when computing
10173 the value of an entity. GDB fetches the value of an entity based
10174 on the size of its type, and thus a wrong size causes GDB to fetch
10175 the wrong amount of memory. In the case where the computed size is
10176 too small, GDB fetches too little data to print the value of our
10177 entiry. Results in this case as unpredicatble, as we usually read
10178 past the buffer containing the data =:-o. */
10179
10180/* Implement the evaluate_exp routine in the exp_descriptor structure
10181 for the Ada language. */
10182
52ce6436 10183static struct value *
ebf56fd3 10184ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 10185 int *pos, enum noside noside)
14f9c5c9
AS
10186{
10187 enum exp_opcode op;
b5385fc0 10188 int tem;
14f9c5c9 10189 int pc;
5ec18f2b 10190 int preeval_pos;
14f9c5c9
AS
10191 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10192 struct type *type;
52ce6436 10193 int nargs, oplen;
d2e4a39e 10194 struct value **argvec;
14f9c5c9 10195
d2e4a39e
AS
10196 pc = *pos;
10197 *pos += 1;
14f9c5c9
AS
10198 op = exp->elts[pc].opcode;
10199
d2e4a39e 10200 switch (op)
14f9c5c9
AS
10201 {
10202 default:
10203 *pos -= 1;
6e48bd2c 10204 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
ca1f964d
JG
10205
10206 if (noside == EVAL_NORMAL)
10207 arg1 = unwrap_value (arg1);
6e48bd2c
JB
10208
10209 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
10210 then we need to perform the conversion manually, because
10211 evaluate_subexp_standard doesn't do it. This conversion is
10212 necessary in Ada because the different kinds of float/fixed
10213 types in Ada have different representations.
10214
10215 Similarly, we need to perform the conversion from OP_LONG
10216 ourselves. */
10217 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
10218 arg1 = ada_value_cast (expect_type, arg1, noside);
10219
10220 return arg1;
4c4b4cd2
PH
10221
10222 case OP_STRING:
10223 {
76a01679 10224 struct value *result;
5b4ee69b 10225
76a01679
JB
10226 *pos -= 1;
10227 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10228 /* The result type will have code OP_STRING, bashed there from
10229 OP_ARRAY. Bash it back. */
df407dfe
AC
10230 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10231 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
76a01679 10232 return result;
4c4b4cd2 10233 }
14f9c5c9
AS
10234
10235 case UNOP_CAST:
10236 (*pos) += 2;
10237 type = exp->elts[pc + 1].type;
10238 arg1 = evaluate_subexp (type, exp, pos, noside);
10239 if (noside == EVAL_SKIP)
4c4b4cd2 10240 goto nosideret;
6e48bd2c 10241 arg1 = ada_value_cast (type, arg1, noside);
14f9c5c9
AS
10242 return arg1;
10243
4c4b4cd2
PH
10244 case UNOP_QUAL:
10245 (*pos) += 2;
10246 type = exp->elts[pc + 1].type;
10247 return ada_evaluate_subexp (type, exp, pos, noside);
10248
14f9c5c9
AS
10249 case BINOP_ASSIGN:
10250 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
52ce6436
PH
10251 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10252 {
10253 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10254 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10255 return arg1;
10256 return ada_value_assign (arg1, arg1);
10257 }
003f3813
JB
10258 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10259 except if the lhs of our assignment is a convenience variable.
10260 In the case of assigning to a convenience variable, the lhs
10261 should be exactly the result of the evaluation of the rhs. */
10262 type = value_type (arg1);
10263 if (VALUE_LVAL (arg1) == lval_internalvar)
10264 type = NULL;
10265 arg2 = evaluate_subexp (type, exp, pos, noside);
14f9c5c9 10266 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10267 return arg1;
df407dfe
AC
10268 if (ada_is_fixed_point_type (value_type (arg1)))
10269 arg2 = cast_to_fixed (value_type (arg1), arg2);
10270 else if (ada_is_fixed_point_type (value_type (arg2)))
76a01679 10271 error
323e0a4a 10272 (_("Fixed-point values must be assigned to fixed-point variables"));
d2e4a39e 10273 else
df407dfe 10274 arg2 = coerce_for_assign (value_type (arg1), arg2);
4c4b4cd2 10275 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
10276
10277 case BINOP_ADD:
10278 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10279 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10280 if (noside == EVAL_SKIP)
4c4b4cd2 10281 goto nosideret;
2ac8a782
JB
10282 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10283 return (value_from_longest
10284 (value_type (arg1),
10285 value_as_long (arg1) + value_as_long (arg2)));
c40cc657
JB
10286 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10287 return (value_from_longest
10288 (value_type (arg2),
10289 value_as_long (arg1) + value_as_long (arg2)));
df407dfe
AC
10290 if ((ada_is_fixed_point_type (value_type (arg1))
10291 || ada_is_fixed_point_type (value_type (arg2)))
10292 && value_type (arg1) != value_type (arg2))
323e0a4a 10293 error (_("Operands of fixed-point addition must have the same type"));
b7789565
JB
10294 /* Do the addition, and cast the result to the type of the first
10295 argument. We cannot cast the result to a reference type, so if
10296 ARG1 is a reference type, find its underlying type. */
10297 type = value_type (arg1);
10298 while (TYPE_CODE (type) == TYPE_CODE_REF)
10299 type = TYPE_TARGET_TYPE (type);
f44316fa 10300 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10301 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
14f9c5c9
AS
10302
10303 case BINOP_SUB:
10304 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10305 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10306 if (noside == EVAL_SKIP)
4c4b4cd2 10307 goto nosideret;
2ac8a782
JB
10308 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10309 return (value_from_longest
10310 (value_type (arg1),
10311 value_as_long (arg1) - value_as_long (arg2)));
c40cc657
JB
10312 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10313 return (value_from_longest
10314 (value_type (arg2),
10315 value_as_long (arg1) - value_as_long (arg2)));
df407dfe
AC
10316 if ((ada_is_fixed_point_type (value_type (arg1))
10317 || ada_is_fixed_point_type (value_type (arg2)))
10318 && value_type (arg1) != value_type (arg2))
0963b4bd
MS
10319 error (_("Operands of fixed-point subtraction "
10320 "must have the same type"));
b7789565
JB
10321 /* Do the substraction, and cast the result to the type of the first
10322 argument. We cannot cast the result to a reference type, so if
10323 ARG1 is a reference type, find its underlying type. */
10324 type = value_type (arg1);
10325 while (TYPE_CODE (type) == TYPE_CODE_REF)
10326 type = TYPE_TARGET_TYPE (type);
f44316fa 10327 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
89eef114 10328 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
14f9c5c9
AS
10329
10330 case BINOP_MUL:
10331 case BINOP_DIV:
e1578042
JB
10332 case BINOP_REM:
10333 case BINOP_MOD:
14f9c5c9
AS
10334 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10335 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10336 if (noside == EVAL_SKIP)
4c4b4cd2 10337 goto nosideret;
e1578042 10338 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9c2be529
JB
10339 {
10340 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10341 return value_zero (value_type (arg1), not_lval);
10342 }
14f9c5c9 10343 else
4c4b4cd2 10344 {
a53b7a21 10345 type = builtin_type (exp->gdbarch)->builtin_double;
df407dfe 10346 if (ada_is_fixed_point_type (value_type (arg1)))
a53b7a21 10347 arg1 = cast_from_fixed (type, arg1);
df407dfe 10348 if (ada_is_fixed_point_type (value_type (arg2)))
a53b7a21 10349 arg2 = cast_from_fixed (type, arg2);
f44316fa 10350 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
4c4b4cd2
PH
10351 return ada_value_binop (arg1, arg2, op);
10352 }
10353
4c4b4cd2
PH
10354 case BINOP_EQUAL:
10355 case BINOP_NOTEQUAL:
14f9c5c9 10356 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
df407dfe 10357 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
14f9c5c9 10358 if (noside == EVAL_SKIP)
76a01679 10359 goto nosideret;
4c4b4cd2 10360 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10361 tem = 0;
4c4b4cd2 10362 else
f44316fa
UW
10363 {
10364 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10365 tem = ada_value_equal (arg1, arg2);
10366 }
4c4b4cd2 10367 if (op == BINOP_NOTEQUAL)
76a01679 10368 tem = !tem;
fbb06eb1
UW
10369 type = language_bool_type (exp->language_defn, exp->gdbarch);
10370 return value_from_longest (type, (LONGEST) tem);
4c4b4cd2
PH
10371
10372 case UNOP_NEG:
10373 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10374 if (noside == EVAL_SKIP)
10375 goto nosideret;
df407dfe
AC
10376 else if (ada_is_fixed_point_type (value_type (arg1)))
10377 return value_cast (value_type (arg1), value_neg (arg1));
14f9c5c9 10378 else
f44316fa
UW
10379 {
10380 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10381 return value_neg (arg1);
10382 }
4c4b4cd2 10383
2330c6c6
JB
10384 case BINOP_LOGICAL_AND:
10385 case BINOP_LOGICAL_OR:
10386 case UNOP_LOGICAL_NOT:
000d5124
JB
10387 {
10388 struct value *val;
10389
10390 *pos -= 1;
10391 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
fbb06eb1
UW
10392 type = language_bool_type (exp->language_defn, exp->gdbarch);
10393 return value_cast (type, val);
000d5124 10394 }
2330c6c6
JB
10395
10396 case BINOP_BITWISE_AND:
10397 case BINOP_BITWISE_IOR:
10398 case BINOP_BITWISE_XOR:
000d5124
JB
10399 {
10400 struct value *val;
10401
10402 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10403 *pos = pc;
10404 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10405
10406 return value_cast (value_type (arg1), val);
10407 }
2330c6c6 10408
14f9c5c9
AS
10409 case OP_VAR_VALUE:
10410 *pos -= 1;
6799def4 10411
14f9c5c9 10412 if (noside == EVAL_SKIP)
4c4b4cd2
PH
10413 {
10414 *pos += 4;
10415 goto nosideret;
10416 }
da5c522f
JB
10417
10418 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
10419 /* Only encountered when an unresolved symbol occurs in a
10420 context other than a function call, in which case, it is
52ce6436 10421 invalid. */
323e0a4a 10422 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2 10423 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
da5c522f
JB
10424
10425 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 10426 {
0c1f74cf 10427 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
31dbc1c5
JB
10428 /* Check to see if this is a tagged type. We also need to handle
10429 the case where the type is a reference to a tagged type, but
10430 we have to be careful to exclude pointers to tagged types.
10431 The latter should be shown as usual (as a pointer), whereas
10432 a reference should mostly be transparent to the user. */
10433 if (ada_is_tagged_type (type, 0)
023db19c 10434 || (TYPE_CODE (type) == TYPE_CODE_REF
31dbc1c5 10435 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
0d72a7c3
JB
10436 {
10437 /* Tagged types are a little special in the fact that the real
10438 type is dynamic and can only be determined by inspecting the
10439 object's tag. This means that we need to get the object's
10440 value first (EVAL_NORMAL) and then extract the actual object
10441 type from its tag.
10442
10443 Note that we cannot skip the final step where we extract
10444 the object type from its tag, because the EVAL_NORMAL phase
10445 results in dynamic components being resolved into fixed ones.
10446 This can cause problems when trying to print the type
10447 description of tagged types whose parent has a dynamic size:
10448 We use the type name of the "_parent" component in order
10449 to print the name of the ancestor type in the type description.
10450 If that component had a dynamic size, the resolution into
10451 a fixed type would result in the loss of that type name,
10452 thus preventing us from printing the name of the ancestor
10453 type in the type description. */
10454 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10455
10456 if (TYPE_CODE (type) != TYPE_CODE_REF)
10457 {
10458 struct type *actual_type;
10459
10460 actual_type = type_from_tag (ada_value_tag (arg1));
10461 if (actual_type == NULL)
10462 /* If, for some reason, we were unable to determine
10463 the actual type from the tag, then use the static
10464 approximation that we just computed as a fallback.
10465 This can happen if the debugging information is
10466 incomplete, for instance. */
10467 actual_type = type;
10468 return value_zero (actual_type, not_lval);
10469 }
10470 else
10471 {
10472 /* In the case of a ref, ada_coerce_ref takes care
10473 of determining the actual type. But the evaluation
10474 should return a ref as it should be valid to ask
10475 for its address; so rebuild a ref after coerce. */
10476 arg1 = ada_coerce_ref (arg1);
10477 return value_ref (arg1);
10478 }
10479 }
0c1f74cf 10480
84754697
JB
10481 /* Records and unions for which GNAT encodings have been
10482 generated need to be statically fixed as well.
10483 Otherwise, non-static fixing produces a type where
10484 all dynamic properties are removed, which prevents "ptype"
10485 from being able to completely describe the type.
10486 For instance, a case statement in a variant record would be
10487 replaced by the relevant components based on the actual
10488 value of the discriminants. */
10489 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10490 && dynamic_template_type (type) != NULL)
10491 || (TYPE_CODE (type) == TYPE_CODE_UNION
10492 && ada_find_parallel_type (type, "___XVU") != NULL))
10493 {
10494 *pos += 4;
10495 return value_zero (to_static_fixed_type (type), not_lval);
10496 }
4c4b4cd2 10497 }
da5c522f
JB
10498
10499 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10500 return ada_to_fixed_value (arg1);
4c4b4cd2
PH
10501
10502 case OP_FUNCALL:
10503 (*pos) += 2;
10504
10505 /* Allocate arg vector, including space for the function to be
10506 called in argvec[0] and a terminating NULL. */
10507 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10508 argvec =
10509 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
10510
10511 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 10512 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
323e0a4a 10513 error (_("Unexpected unresolved symbol, %s, during evaluation"),
4c4b4cd2
PH
10514 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10515 else
10516 {
10517 for (tem = 0; tem <= nargs; tem += 1)
10518 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10519 argvec[tem] = 0;
10520
10521 if (noside == EVAL_SKIP)
10522 goto nosideret;
10523 }
10524
ad82864c
JB
10525 if (ada_is_constrained_packed_array_type
10526 (desc_base_type (value_type (argvec[0]))))
4c4b4cd2 10527 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
284614f0
JB
10528 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10529 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10530 /* This is a packed array that has already been fixed, and
10531 therefore already coerced to a simple array. Nothing further
10532 to do. */
10533 ;
df407dfe
AC
10534 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
10535 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
76a01679 10536 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
10537 argvec[0] = value_addr (argvec[0]);
10538
df407dfe 10539 type = ada_check_typedef (value_type (argvec[0]));
720d1a40
JB
10540
10541 /* Ada allows us to implicitly dereference arrays when subscripting
8f465ea7
JB
10542 them. So, if this is an array typedef (encoding use for array
10543 access types encoded as fat pointers), strip it now. */
720d1a40
JB
10544 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10545 type = ada_typedef_target_type (type);
10546
4c4b4cd2
PH
10547 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10548 {
61ee279c 10549 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
4c4b4cd2
PH
10550 {
10551 case TYPE_CODE_FUNC:
61ee279c 10552 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10553 break;
10554 case TYPE_CODE_ARRAY:
10555 break;
10556 case TYPE_CODE_STRUCT:
10557 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10558 argvec[0] = ada_value_ind (argvec[0]);
61ee279c 10559 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
4c4b4cd2
PH
10560 break;
10561 default:
323e0a4a 10562 error (_("cannot subscript or call something of type `%s'"),
df407dfe 10563 ada_type_name (value_type (argvec[0])));
4c4b4cd2
PH
10564 break;
10565 }
10566 }
10567
10568 switch (TYPE_CODE (type))
10569 {
10570 case TYPE_CODE_FUNC:
10571 if (noside == EVAL_AVOID_SIDE_EFFECTS)
c8ea1972
PH
10572 {
10573 struct type *rtype = TYPE_TARGET_TYPE (type);
10574
10575 if (TYPE_GNU_IFUNC (type))
10576 return allocate_value (TYPE_TARGET_TYPE (rtype));
10577 return allocate_value (rtype);
10578 }
4c4b4cd2 10579 return call_function_by_hand (argvec[0], nargs, argvec + 1);
c8ea1972
PH
10580 case TYPE_CODE_INTERNAL_FUNCTION:
10581 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10582 /* We don't know anything about what the internal
10583 function might return, but we have to return
10584 something. */
10585 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10586 not_lval);
10587 else
10588 return call_internal_function (exp->gdbarch, exp->language_defn,
10589 argvec[0], nargs, argvec + 1);
10590
4c4b4cd2
PH
10591 case TYPE_CODE_STRUCT:
10592 {
10593 int arity;
10594
4c4b4cd2
PH
10595 arity = ada_array_arity (type);
10596 type = ada_array_element_type (type, nargs);
10597 if (type == NULL)
323e0a4a 10598 error (_("cannot subscript or call a record"));
4c4b4cd2 10599 if (arity != nargs)
323e0a4a 10600 error (_("wrong number of subscripts; expecting %d"), arity);
4c4b4cd2 10601 if (noside == EVAL_AVOID_SIDE_EFFECTS)
0a07e705 10602 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10603 return
10604 unwrap_value (ada_value_subscript
10605 (argvec[0], nargs, argvec + 1));
10606 }
10607 case TYPE_CODE_ARRAY:
10608 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10609 {
10610 type = ada_array_element_type (type, nargs);
10611 if (type == NULL)
323e0a4a 10612 error (_("element type of array unknown"));
4c4b4cd2 10613 else
0a07e705 10614 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10615 }
10616 return
10617 unwrap_value (ada_value_subscript
10618 (ada_coerce_to_simple_array (argvec[0]),
10619 nargs, argvec + 1));
10620 case TYPE_CODE_PTR: /* Pointer to array */
4c4b4cd2
PH
10621 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10622 {
deede10c 10623 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
4c4b4cd2
PH
10624 type = ada_array_element_type (type, nargs);
10625 if (type == NULL)
323e0a4a 10626 error (_("element type of array unknown"));
4c4b4cd2 10627 else
0a07e705 10628 return value_zero (ada_aligned_type (type), lval_memory);
4c4b4cd2
PH
10629 }
10630 return
deede10c
JB
10631 unwrap_value (ada_value_ptr_subscript (argvec[0],
10632 nargs, argvec + 1));
4c4b4cd2
PH
10633
10634 default:
e1d5a0d2
PH
10635 error (_("Attempt to index or call something other than an "
10636 "array or function"));
4c4b4cd2
PH
10637 }
10638
10639 case TERNOP_SLICE:
10640 {
10641 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10642 struct value *low_bound_val =
10643 evaluate_subexp (NULL_TYPE, exp, pos, noside);
714e53ab
PH
10644 struct value *high_bound_val =
10645 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10646 LONGEST low_bound;
10647 LONGEST high_bound;
5b4ee69b 10648
994b9211
AC
10649 low_bound_val = coerce_ref (low_bound_val);
10650 high_bound_val = coerce_ref (high_bound_val);
aa715135
JG
10651 low_bound = value_as_long (low_bound_val);
10652 high_bound = value_as_long (high_bound_val);
963a6417 10653
4c4b4cd2
PH
10654 if (noside == EVAL_SKIP)
10655 goto nosideret;
10656
4c4b4cd2
PH
10657 /* If this is a reference to an aligner type, then remove all
10658 the aligners. */
df407dfe
AC
10659 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10660 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10661 TYPE_TARGET_TYPE (value_type (array)) =
10662 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
4c4b4cd2 10663
ad82864c 10664 if (ada_is_constrained_packed_array_type (value_type (array)))
323e0a4a 10665 error (_("cannot slice a packed array"));
4c4b4cd2
PH
10666
10667 /* If this is a reference to an array or an array lvalue,
10668 convert to a pointer. */
df407dfe
AC
10669 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10670 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
4c4b4cd2
PH
10671 && VALUE_LVAL (array) == lval_memory))
10672 array = value_addr (array);
10673
1265e4aa 10674 if (noside == EVAL_AVOID_SIDE_EFFECTS
61ee279c 10675 && ada_is_array_descriptor_type (ada_check_typedef
df407dfe 10676 (value_type (array))))
0b5d8877 10677 return empty_array (ada_type_of_array (array, 0), low_bound);
4c4b4cd2
PH
10678
10679 array = ada_coerce_to_simple_array_ptr (array);
10680
714e53ab
PH
10681 /* If we have more than one level of pointer indirection,
10682 dereference the value until we get only one level. */
df407dfe
AC
10683 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10684 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
714e53ab
PH
10685 == TYPE_CODE_PTR))
10686 array = value_ind (array);
10687
10688 /* Make sure we really do have an array type before going further,
10689 to avoid a SEGV when trying to get the index type or the target
10690 type later down the road if the debug info generated by
10691 the compiler is incorrect or incomplete. */
df407dfe 10692 if (!ada_is_simple_array_type (value_type (array)))
323e0a4a 10693 error (_("cannot take slice of non-array"));
714e53ab 10694
828292f2
JB
10695 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10696 == TYPE_CODE_PTR)
4c4b4cd2 10697 {
828292f2
JB
10698 struct type *type0 = ada_check_typedef (value_type (array));
10699
0b5d8877 10700 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
828292f2 10701 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
4c4b4cd2
PH
10702 else
10703 {
10704 struct type *arr_type0 =
828292f2 10705 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
5b4ee69b 10706
f5938064
JG
10707 return ada_value_slice_from_ptr (array, arr_type0,
10708 longest_to_int (low_bound),
10709 longest_to_int (high_bound));
4c4b4cd2
PH
10710 }
10711 }
10712 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10713 return array;
10714 else if (high_bound < low_bound)
df407dfe 10715 return empty_array (value_type (array), low_bound);
4c4b4cd2 10716 else
529cad9c
PH
10717 return ada_value_slice (array, longest_to_int (low_bound),
10718 longest_to_int (high_bound));
4c4b4cd2 10719 }
14f9c5c9 10720
4c4b4cd2
PH
10721 case UNOP_IN_RANGE:
10722 (*pos) += 2;
10723 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8008e265 10724 type = check_typedef (exp->elts[pc + 1].type);
14f9c5c9 10725
14f9c5c9 10726 if (noside == EVAL_SKIP)
4c4b4cd2 10727 goto nosideret;
14f9c5c9 10728
4c4b4cd2
PH
10729 switch (TYPE_CODE (type))
10730 {
10731 default:
e1d5a0d2
PH
10732 lim_warning (_("Membership test incompletely implemented; "
10733 "always returns true"));
fbb06eb1
UW
10734 type = language_bool_type (exp->language_defn, exp->gdbarch);
10735 return value_from_longest (type, (LONGEST) 1);
4c4b4cd2
PH
10736
10737 case TYPE_CODE_RANGE:
030b4912
UW
10738 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10739 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
f44316fa
UW
10740 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10741 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1
UW
10742 type = language_bool_type (exp->language_defn, exp->gdbarch);
10743 return
10744 value_from_longest (type,
4c4b4cd2
PH
10745 (value_less (arg1, arg3)
10746 || value_equal (arg1, arg3))
10747 && (value_less (arg2, arg1)
10748 || value_equal (arg2, arg1)));
10749 }
10750
10751 case BINOP_IN_BOUNDS:
14f9c5c9 10752 (*pos) += 2;
4c4b4cd2
PH
10753 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10754 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 10755
4c4b4cd2
PH
10756 if (noside == EVAL_SKIP)
10757 goto nosideret;
14f9c5c9 10758
4c4b4cd2 10759 if (noside == EVAL_AVOID_SIDE_EFFECTS)
fbb06eb1
UW
10760 {
10761 type = language_bool_type (exp->language_defn, exp->gdbarch);
10762 return value_zero (type, not_lval);
10763 }
14f9c5c9 10764
4c4b4cd2 10765 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 10766
1eea4ebd
UW
10767 type = ada_index_type (value_type (arg2), tem, "range");
10768 if (!type)
10769 type = value_type (arg1);
14f9c5c9 10770
1eea4ebd
UW
10771 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10772 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
d2e4a39e 10773
f44316fa
UW
10774 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10775 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10776 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10777 return
fbb06eb1 10778 value_from_longest (type,
4c4b4cd2
PH
10779 (value_less (arg1, arg3)
10780 || value_equal (arg1, arg3))
10781 && (value_less (arg2, arg1)
10782 || value_equal (arg2, arg1)));
10783
10784 case TERNOP_IN_RANGE:
10785 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10786 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10787 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10788
10789 if (noside == EVAL_SKIP)
10790 goto nosideret;
10791
f44316fa
UW
10792 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10793 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
fbb06eb1 10794 type = language_bool_type (exp->language_defn, exp->gdbarch);
4c4b4cd2 10795 return
fbb06eb1 10796 value_from_longest (type,
4c4b4cd2
PH
10797 (value_less (arg1, arg3)
10798 || value_equal (arg1, arg3))
10799 && (value_less (arg2, arg1)
10800 || value_equal (arg2, arg1)));
10801
10802 case OP_ATR_FIRST:
10803 case OP_ATR_LAST:
10804 case OP_ATR_LENGTH:
10805 {
76a01679 10806 struct type *type_arg;
5b4ee69b 10807
76a01679
JB
10808 if (exp->elts[*pos].opcode == OP_TYPE)
10809 {
10810 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10811 arg1 = NULL;
5bc23cb3 10812 type_arg = check_typedef (exp->elts[pc + 2].type);
76a01679
JB
10813 }
10814 else
10815 {
10816 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10817 type_arg = NULL;
10818 }
10819
10820 if (exp->elts[*pos].opcode != OP_LONG)
323e0a4a 10821 error (_("Invalid operand to '%s"), ada_attribute_name (op));
76a01679
JB
10822 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10823 *pos += 4;
10824
10825 if (noside == EVAL_SKIP)
10826 goto nosideret;
10827
10828 if (type_arg == NULL)
10829 {
10830 arg1 = ada_coerce_ref (arg1);
10831
ad82864c 10832 if (ada_is_constrained_packed_array_type (value_type (arg1)))
76a01679
JB
10833 arg1 = ada_coerce_to_simple_array (arg1);
10834
aa4fb036 10835 if (op == OP_ATR_LENGTH)
1eea4ebd 10836 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10837 else
10838 {
10839 type = ada_index_type (value_type (arg1), tem,
10840 ada_attribute_name (op));
10841 if (type == NULL)
10842 type = builtin_type (exp->gdbarch)->builtin_int;
10843 }
76a01679
JB
10844
10845 if (noside == EVAL_AVOID_SIDE_EFFECTS)
1eea4ebd 10846 return allocate_value (type);
76a01679
JB
10847
10848 switch (op)
10849 {
10850 default: /* Should never happen. */
323e0a4a 10851 error (_("unexpected attribute encountered"));
76a01679 10852 case OP_ATR_FIRST:
1eea4ebd
UW
10853 return value_from_longest
10854 (type, ada_array_bound (arg1, tem, 0));
76a01679 10855 case OP_ATR_LAST:
1eea4ebd
UW
10856 return value_from_longest
10857 (type, ada_array_bound (arg1, tem, 1));
76a01679 10858 case OP_ATR_LENGTH:
1eea4ebd
UW
10859 return value_from_longest
10860 (type, ada_array_length (arg1, tem));
76a01679
JB
10861 }
10862 }
10863 else if (discrete_type_p (type_arg))
10864 {
10865 struct type *range_type;
0d5cff50 10866 const char *name = ada_type_name (type_arg);
5b4ee69b 10867
76a01679
JB
10868 range_type = NULL;
10869 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
28c85d6c 10870 range_type = to_fixed_range_type (type_arg, NULL);
76a01679
JB
10871 if (range_type == NULL)
10872 range_type = type_arg;
10873 switch (op)
10874 {
10875 default:
323e0a4a 10876 error (_("unexpected attribute encountered"));
76a01679 10877 case OP_ATR_FIRST:
690cc4eb 10878 return value_from_longest
43bbcdc2 10879 (range_type, ada_discrete_type_low_bound (range_type));
76a01679 10880 case OP_ATR_LAST:
690cc4eb 10881 return value_from_longest
43bbcdc2 10882 (range_type, ada_discrete_type_high_bound (range_type));
76a01679 10883 case OP_ATR_LENGTH:
323e0a4a 10884 error (_("the 'length attribute applies only to array types"));
76a01679
JB
10885 }
10886 }
10887 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
323e0a4a 10888 error (_("unimplemented type attribute"));
76a01679
JB
10889 else
10890 {
10891 LONGEST low, high;
10892
ad82864c
JB
10893 if (ada_is_constrained_packed_array_type (type_arg))
10894 type_arg = decode_constrained_packed_array_type (type_arg);
76a01679 10895
aa4fb036 10896 if (op == OP_ATR_LENGTH)
1eea4ebd 10897 type = builtin_type (exp->gdbarch)->builtin_int;
aa4fb036
JB
10898 else
10899 {
10900 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10901 if (type == NULL)
10902 type = builtin_type (exp->gdbarch)->builtin_int;
10903 }
1eea4ebd 10904
76a01679
JB
10905 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10906 return allocate_value (type);
10907
10908 switch (op)
10909 {
10910 default:
323e0a4a 10911 error (_("unexpected attribute encountered"));
76a01679 10912 case OP_ATR_FIRST:
1eea4ebd 10913 low = ada_array_bound_from_type (type_arg, tem, 0);
76a01679
JB
10914 return value_from_longest (type, low);
10915 case OP_ATR_LAST:
1eea4ebd 10916 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10917 return value_from_longest (type, high);
10918 case OP_ATR_LENGTH:
1eea4ebd
UW
10919 low = ada_array_bound_from_type (type_arg, tem, 0);
10920 high = ada_array_bound_from_type (type_arg, tem, 1);
76a01679
JB
10921 return value_from_longest (type, high - low + 1);
10922 }
10923 }
14f9c5c9
AS
10924 }
10925
4c4b4cd2
PH
10926 case OP_ATR_TAG:
10927 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10928 if (noside == EVAL_SKIP)
76a01679 10929 goto nosideret;
4c4b4cd2
PH
10930
10931 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 10932 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
10933
10934 return ada_value_tag (arg1);
10935
10936 case OP_ATR_MIN:
10937 case OP_ATR_MAX:
10938 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10939 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10940 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10941 if (noside == EVAL_SKIP)
76a01679 10942 goto nosideret;
d2e4a39e 10943 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 10944 return value_zero (value_type (arg1), not_lval);
14f9c5c9 10945 else
f44316fa
UW
10946 {
10947 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10948 return value_binop (arg1, arg2,
10949 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10950 }
14f9c5c9 10951
4c4b4cd2
PH
10952 case OP_ATR_MODULUS:
10953 {
31dedfee 10954 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
4c4b4cd2 10955
5b4ee69b 10956 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
76a01679
JB
10957 if (noside == EVAL_SKIP)
10958 goto nosideret;
4c4b4cd2 10959
76a01679 10960 if (!ada_is_modular_type (type_arg))
323e0a4a 10961 error (_("'modulus must be applied to modular type"));
4c4b4cd2 10962
76a01679
JB
10963 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10964 ada_modulus (type_arg));
4c4b4cd2
PH
10965 }
10966
10967
10968 case OP_ATR_POS:
10969 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
10970 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10971 if (noside == EVAL_SKIP)
76a01679 10972 goto nosideret;
3cb382c9
UW
10973 type = builtin_type (exp->gdbarch)->builtin_int;
10974 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10975 return value_zero (type, not_lval);
14f9c5c9 10976 else
3cb382c9 10977 return value_pos_atr (type, arg1);
14f9c5c9 10978
4c4b4cd2
PH
10979 case OP_ATR_SIZE:
10980 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8c1c099f
JB
10981 type = value_type (arg1);
10982
10983 /* If the argument is a reference, then dereference its type, since
10984 the user is really asking for the size of the actual object,
10985 not the size of the pointer. */
10986 if (TYPE_CODE (type) == TYPE_CODE_REF)
10987 type = TYPE_TARGET_TYPE (type);
10988
4c4b4cd2 10989 if (noside == EVAL_SKIP)
76a01679 10990 goto nosideret;
4c4b4cd2 10991 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
22601c15 10992 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
4c4b4cd2 10993 else
22601c15 10994 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
8c1c099f 10995 TARGET_CHAR_BIT * TYPE_LENGTH (type));
4c4b4cd2
PH
10996
10997 case OP_ATR_VAL:
10998 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 10999 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 11000 type = exp->elts[pc + 2].type;
14f9c5c9 11001 if (noside == EVAL_SKIP)
76a01679 11002 goto nosideret;
4c4b4cd2 11003 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11004 return value_zero (type, not_lval);
4c4b4cd2 11005 else
76a01679 11006 return value_val_atr (type, arg1);
4c4b4cd2
PH
11007
11008 case BINOP_EXP:
11009 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11010 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11011 if (noside == EVAL_SKIP)
11012 goto nosideret;
11013 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
df407dfe 11014 return value_zero (value_type (arg1), not_lval);
4c4b4cd2 11015 else
f44316fa
UW
11016 {
11017 /* For integer exponentiation operations,
11018 only promote the first argument. */
11019 if (is_integral_type (value_type (arg2)))
11020 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11021 else
11022 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11023
11024 return value_binop (arg1, arg2, op);
11025 }
4c4b4cd2
PH
11026
11027 case UNOP_PLUS:
11028 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11029 if (noside == EVAL_SKIP)
11030 goto nosideret;
11031 else
11032 return arg1;
11033
11034 case UNOP_ABS:
11035 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11036 if (noside == EVAL_SKIP)
11037 goto nosideret;
f44316fa 11038 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
df407dfe 11039 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
4c4b4cd2 11040 return value_neg (arg1);
14f9c5c9 11041 else
4c4b4cd2 11042 return arg1;
14f9c5c9
AS
11043
11044 case UNOP_IND:
5ec18f2b 11045 preeval_pos = *pos;
6b0d7253 11046 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 11047 if (noside == EVAL_SKIP)
4c4b4cd2 11048 goto nosideret;
df407dfe 11049 type = ada_check_typedef (value_type (arg1));
14f9c5c9 11050 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
11051 {
11052 if (ada_is_array_descriptor_type (type))
11053 /* GDB allows dereferencing GNAT array descriptors. */
11054 {
11055 struct type *arrType = ada_type_of_array (arg1, 0);
5b4ee69b 11056
4c4b4cd2 11057 if (arrType == NULL)
323e0a4a 11058 error (_("Attempt to dereference null array pointer."));
00a4c844 11059 return value_at_lazy (arrType, 0);
4c4b4cd2
PH
11060 }
11061 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11062 || TYPE_CODE (type) == TYPE_CODE_REF
11063 /* In C you can dereference an array to get the 1st elt. */
11064 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
714e53ab 11065 {
5ec18f2b
JG
11066 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11067 only be determined by inspecting the object's tag.
11068 This means that we need to evaluate completely the
11069 expression in order to get its type. */
11070
023db19c
JB
11071 if ((TYPE_CODE (type) == TYPE_CODE_REF
11072 || TYPE_CODE (type) == TYPE_CODE_PTR)
5ec18f2b
JG
11073 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11074 {
11075 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11076 EVAL_NORMAL);
11077 type = value_type (ada_value_ind (arg1));
11078 }
11079 else
11080 {
11081 type = to_static_fixed_type
11082 (ada_aligned_type
11083 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11084 }
c1b5a1a6 11085 ada_ensure_varsize_limit (type);
714e53ab
PH
11086 return value_zero (type, lval_memory);
11087 }
4c4b4cd2 11088 else if (TYPE_CODE (type) == TYPE_CODE_INT)
6b0d7253
JB
11089 {
11090 /* GDB allows dereferencing an int. */
11091 if (expect_type == NULL)
11092 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11093 lval_memory);
11094 else
11095 {
11096 expect_type =
11097 to_static_fixed_type (ada_aligned_type (expect_type));
11098 return value_zero (expect_type, lval_memory);
11099 }
11100 }
4c4b4cd2 11101 else
323e0a4a 11102 error (_("Attempt to take contents of a non-pointer value."));
4c4b4cd2 11103 }
0963b4bd 11104 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
df407dfe 11105 type = ada_check_typedef (value_type (arg1));
d2e4a39e 11106
96967637
JB
11107 if (TYPE_CODE (type) == TYPE_CODE_INT)
11108 /* GDB allows dereferencing an int. If we were given
11109 the expect_type, then use that as the target type.
11110 Otherwise, assume that the target type is an int. */
11111 {
11112 if (expect_type != NULL)
11113 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11114 arg1));
11115 else
11116 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11117 (CORE_ADDR) value_as_address (arg1));
11118 }
6b0d7253 11119
4c4b4cd2
PH
11120 if (ada_is_array_descriptor_type (type))
11121 /* GDB allows dereferencing GNAT array descriptors. */
11122 return ada_coerce_to_simple_array (arg1);
14f9c5c9 11123 else
4c4b4cd2 11124 return ada_value_ind (arg1);
14f9c5c9
AS
11125
11126 case STRUCTOP_STRUCT:
11127 tem = longest_to_int (exp->elts[pc + 1].longconst);
11128 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
5ec18f2b 11129 preeval_pos = *pos;
14f9c5c9
AS
11130 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11131 if (noside == EVAL_SKIP)
4c4b4cd2 11132 goto nosideret;
14f9c5c9 11133 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 11134 {
df407dfe 11135 struct type *type1 = value_type (arg1);
5b4ee69b 11136
76a01679
JB
11137 if (ada_is_tagged_type (type1, 1))
11138 {
11139 type = ada_lookup_struct_elt_type (type1,
11140 &exp->elts[pc + 2].string,
11141 1, 1, NULL);
5ec18f2b
JG
11142
11143 /* If the field is not found, check if it exists in the
11144 extension of this object's type. This means that we
11145 need to evaluate completely the expression. */
11146
76a01679 11147 if (type == NULL)
5ec18f2b
JG
11148 {
11149 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11150 EVAL_NORMAL);
11151 arg1 = ada_value_struct_elt (arg1,
11152 &exp->elts[pc + 2].string,
11153 0);
11154 arg1 = unwrap_value (arg1);
11155 type = value_type (ada_to_fixed_value (arg1));
11156 }
76a01679
JB
11157 }
11158 else
11159 type =
11160 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11161 0, NULL);
11162
11163 return value_zero (ada_aligned_type (type), lval_memory);
11164 }
14f9c5c9 11165 else
284614f0
JB
11166 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11167 arg1 = unwrap_value (arg1);
11168 return ada_to_fixed_value (arg1);
11169
14f9c5c9 11170 case OP_TYPE:
4c4b4cd2
PH
11171 /* The value is not supposed to be used. This is here to make it
11172 easier to accommodate expressions that contain types. */
14f9c5c9
AS
11173 (*pos) += 2;
11174 if (noside == EVAL_SKIP)
4c4b4cd2 11175 goto nosideret;
14f9c5c9 11176 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
a6cfbe68 11177 return allocate_value (exp->elts[pc + 1].type);
14f9c5c9 11178 else
323e0a4a 11179 error (_("Attempt to use a type name as an expression"));
52ce6436
PH
11180
11181 case OP_AGGREGATE:
11182 case OP_CHOICES:
11183 case OP_OTHERS:
11184 case OP_DISCRETE_RANGE:
11185 case OP_POSITIONAL:
11186 case OP_NAME:
11187 if (noside == EVAL_NORMAL)
11188 switch (op)
11189 {
11190 case OP_NAME:
11191 error (_("Undefined name, ambiguous name, or renaming used in "
e1d5a0d2 11192 "component association: %s."), &exp->elts[pc+2].string);
52ce6436
PH
11193 case OP_AGGREGATE:
11194 error (_("Aggregates only allowed on the right of an assignment"));
11195 default:
0963b4bd
MS
11196 internal_error (__FILE__, __LINE__,
11197 _("aggregate apparently mangled"));
52ce6436
PH
11198 }
11199
11200 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11201 *pos += oplen - 1;
11202 for (tem = 0; tem < nargs; tem += 1)
11203 ada_evaluate_subexp (NULL, exp, pos, noside);
11204 goto nosideret;
14f9c5c9
AS
11205 }
11206
11207nosideret:
22601c15 11208 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
14f9c5c9 11209}
14f9c5c9 11210\f
d2e4a39e 11211
4c4b4cd2 11212 /* Fixed point */
14f9c5c9
AS
11213
11214/* If TYPE encodes an Ada fixed-point type, return the suffix of the
11215 type name that encodes the 'small and 'delta information.
4c4b4cd2 11216 Otherwise, return NULL. */
14f9c5c9 11217
d2e4a39e 11218static const char *
ebf56fd3 11219fixed_type_info (struct type *type)
14f9c5c9 11220{
d2e4a39e 11221 const char *name = ada_type_name (type);
14f9c5c9
AS
11222 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11223
d2e4a39e
AS
11224 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11225 {
14f9c5c9 11226 const char *tail = strstr (name, "___XF_");
5b4ee69b 11227
14f9c5c9 11228 if (tail == NULL)
4c4b4cd2 11229 return NULL;
d2e4a39e 11230 else
4c4b4cd2 11231 return tail + 5;
14f9c5c9
AS
11232 }
11233 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11234 return fixed_type_info (TYPE_TARGET_TYPE (type));
11235 else
11236 return NULL;
11237}
11238
4c4b4cd2 11239/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
11240
11241int
ebf56fd3 11242ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
11243{
11244 return fixed_type_info (type) != NULL;
11245}
11246
4c4b4cd2
PH
11247/* Return non-zero iff TYPE represents a System.Address type. */
11248
11249int
11250ada_is_system_address_type (struct type *type)
11251{
11252 return (TYPE_NAME (type)
11253 && strcmp (TYPE_NAME (type), "system__address") == 0);
11254}
11255
14f9c5c9
AS
11256/* Assuming that TYPE is the representation of an Ada fixed-point
11257 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 11258 delta cannot be determined. */
14f9c5c9
AS
11259
11260DOUBLEST
ebf56fd3 11261ada_delta (struct type *type)
14f9c5c9
AS
11262{
11263 const char *encoding = fixed_type_info (type);
facc390f 11264 DOUBLEST num, den;
14f9c5c9 11265
facc390f
JB
11266 /* Strictly speaking, num and den are encoded as integer. However,
11267 they may not fit into a long, and they will have to be converted
11268 to DOUBLEST anyway. So scan them as DOUBLEST. */
11269 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11270 &num, &den) < 2)
14f9c5c9 11271 return -1.0;
d2e4a39e 11272 else
facc390f 11273 return num / den;
14f9c5c9
AS
11274}
11275
11276/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 11277 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
11278
11279static DOUBLEST
ebf56fd3 11280scaling_factor (struct type *type)
14f9c5c9
AS
11281{
11282 const char *encoding = fixed_type_info (type);
facc390f 11283 DOUBLEST num0, den0, num1, den1;
14f9c5c9 11284 int n;
d2e4a39e 11285
facc390f
JB
11286 /* Strictly speaking, num's and den's are encoded as integer. However,
11287 they may not fit into a long, and they will have to be converted
11288 to DOUBLEST anyway. So scan them as DOUBLEST. */
11289 n = sscanf (encoding,
11290 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
11291 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11292 &num0, &den0, &num1, &den1);
14f9c5c9
AS
11293
11294 if (n < 2)
11295 return 1.0;
11296 else if (n == 4)
facc390f 11297 return num1 / den1;
d2e4a39e 11298 else
facc390f 11299 return num0 / den0;
14f9c5c9
AS
11300}
11301
11302
11303/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 11304 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
11305
11306DOUBLEST
ebf56fd3 11307ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 11308{
d2e4a39e 11309 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
11310}
11311
4c4b4cd2
PH
11312/* The representation of a fixed-point value of type TYPE
11313 corresponding to the value X. */
14f9c5c9
AS
11314
11315LONGEST
ebf56fd3 11316ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
11317{
11318 return (LONGEST) (x / scaling_factor (type) + 0.5);
11319}
11320
14f9c5c9 11321\f
d2e4a39e 11322
4c4b4cd2 11323 /* Range types */
14f9c5c9
AS
11324
11325/* Scan STR beginning at position K for a discriminant name, and
11326 return the value of that discriminant field of DVAL in *PX. If
11327 PNEW_K is not null, put the position of the character beyond the
11328 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 11329 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
11330
11331static int
07d8f827 11332scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 11333 int *pnew_k)
14f9c5c9
AS
11334{
11335 static char *bound_buffer = NULL;
11336 static size_t bound_buffer_len = 0;
11337 char *bound;
11338 char *pend;
d2e4a39e 11339 struct value *bound_val;
14f9c5c9
AS
11340
11341 if (dval == NULL || str == NULL || str[k] == '\0')
11342 return 0;
11343
d2e4a39e 11344 pend = strstr (str + k, "__");
14f9c5c9
AS
11345 if (pend == NULL)
11346 {
d2e4a39e 11347 bound = str + k;
14f9c5c9
AS
11348 k += strlen (bound);
11349 }
d2e4a39e 11350 else
14f9c5c9 11351 {
d2e4a39e 11352 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 11353 bound = bound_buffer;
d2e4a39e
AS
11354 strncpy (bound_buffer, str + k, pend - (str + k));
11355 bound[pend - (str + k)] = '\0';
11356 k = pend - str;
14f9c5c9 11357 }
d2e4a39e 11358
df407dfe 11359 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
14f9c5c9
AS
11360 if (bound_val == NULL)
11361 return 0;
11362
11363 *px = value_as_long (bound_val);
11364 if (pnew_k != NULL)
11365 *pnew_k = k;
11366 return 1;
11367}
11368
11369/* Value of variable named NAME in the current environment. If
11370 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
11371 otherwise causes an error with message ERR_MSG. */
11372
d2e4a39e
AS
11373static struct value *
11374get_var_value (char *name, char *err_msg)
14f9c5c9 11375{
d12307c1 11376 struct block_symbol *syms;
14f9c5c9
AS
11377 int nsyms;
11378
4c4b4cd2 11379 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
4eeaa230 11380 &syms);
14f9c5c9
AS
11381
11382 if (nsyms != 1)
11383 {
11384 if (err_msg == NULL)
4c4b4cd2 11385 return 0;
14f9c5c9 11386 else
8a3fe4f8 11387 error (("%s"), err_msg);
14f9c5c9
AS
11388 }
11389
d12307c1 11390 return value_of_variable (syms[0].symbol, syms[0].block);
14f9c5c9 11391}
d2e4a39e 11392
14f9c5c9 11393/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
11394 no such variable found, returns 0, and sets *FLAG to 0. If
11395 successful, sets *FLAG to 1. */
11396
14f9c5c9 11397LONGEST
4c4b4cd2 11398get_int_var_value (char *name, int *flag)
14f9c5c9 11399{
4c4b4cd2 11400 struct value *var_val = get_var_value (name, 0);
d2e4a39e 11401
14f9c5c9
AS
11402 if (var_val == 0)
11403 {
11404 if (flag != NULL)
4c4b4cd2 11405 *flag = 0;
14f9c5c9
AS
11406 return 0;
11407 }
11408 else
11409 {
11410 if (flag != NULL)
4c4b4cd2 11411 *flag = 1;
14f9c5c9
AS
11412 return value_as_long (var_val);
11413 }
11414}
d2e4a39e 11415
14f9c5c9
AS
11416
11417/* Return a range type whose base type is that of the range type named
11418 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 11419 from NAME according to the GNAT range encoding conventions.
1ce677a4
UW
11420 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11421 corresponding range type from debug information; fall back to using it
11422 if symbol lookup fails. If a new type must be created, allocate it
11423 like ORIG_TYPE was. The bounds information, in general, is encoded
11424 in NAME, the base type given in the named range type. */
14f9c5c9 11425
d2e4a39e 11426static struct type *
28c85d6c 11427to_fixed_range_type (struct type *raw_type, struct value *dval)
14f9c5c9 11428{
0d5cff50 11429 const char *name;
14f9c5c9 11430 struct type *base_type;
d2e4a39e 11431 char *subtype_info;
14f9c5c9 11432
28c85d6c
JB
11433 gdb_assert (raw_type != NULL);
11434 gdb_assert (TYPE_NAME (raw_type) != NULL);
dddfab26 11435
1ce677a4 11436 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
14f9c5c9
AS
11437 base_type = TYPE_TARGET_TYPE (raw_type);
11438 else
11439 base_type = raw_type;
11440
28c85d6c 11441 name = TYPE_NAME (raw_type);
14f9c5c9
AS
11442 subtype_info = strstr (name, "___XD");
11443 if (subtype_info == NULL)
690cc4eb 11444 {
43bbcdc2
PH
11445 LONGEST L = ada_discrete_type_low_bound (raw_type);
11446 LONGEST U = ada_discrete_type_high_bound (raw_type);
5b4ee69b 11447
690cc4eb
PH
11448 if (L < INT_MIN || U > INT_MAX)
11449 return raw_type;
11450 else
0c9c3474
SA
11451 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11452 L, U);
690cc4eb 11453 }
14f9c5c9
AS
11454 else
11455 {
11456 static char *name_buf = NULL;
11457 static size_t name_len = 0;
11458 int prefix_len = subtype_info - name;
11459 LONGEST L, U;
11460 struct type *type;
11461 char *bounds_str;
11462 int n;
11463
11464 GROW_VECT (name_buf, name_len, prefix_len + 5);
11465 strncpy (name_buf, name, prefix_len);
11466 name_buf[prefix_len] = '\0';
11467
11468 subtype_info += 5;
11469 bounds_str = strchr (subtype_info, '_');
11470 n = 1;
11471
d2e4a39e 11472 if (*subtype_info == 'L')
4c4b4cd2
PH
11473 {
11474 if (!ada_scan_number (bounds_str, n, &L, &n)
11475 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11476 return raw_type;
11477 if (bounds_str[n] == '_')
11478 n += 2;
0963b4bd 11479 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
4c4b4cd2
PH
11480 n += 1;
11481 subtype_info += 1;
11482 }
d2e4a39e 11483 else
4c4b4cd2
PH
11484 {
11485 int ok;
5b4ee69b 11486
4c4b4cd2
PH
11487 strcpy (name_buf + prefix_len, "___L");
11488 L = get_int_var_value (name_buf, &ok);
11489 if (!ok)
11490 {
323e0a4a 11491 lim_warning (_("Unknown lower bound, using 1."));
4c4b4cd2
PH
11492 L = 1;
11493 }
11494 }
14f9c5c9 11495
d2e4a39e 11496 if (*subtype_info == 'U')
4c4b4cd2
PH
11497 {
11498 if (!ada_scan_number (bounds_str, n, &U, &n)
11499 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11500 return raw_type;
11501 }
d2e4a39e 11502 else
4c4b4cd2
PH
11503 {
11504 int ok;
5b4ee69b 11505
4c4b4cd2
PH
11506 strcpy (name_buf + prefix_len, "___U");
11507 U = get_int_var_value (name_buf, &ok);
11508 if (!ok)
11509 {
323e0a4a 11510 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
4c4b4cd2
PH
11511 U = L;
11512 }
11513 }
14f9c5c9 11514
0c9c3474
SA
11515 type = create_static_range_type (alloc_type_copy (raw_type),
11516 base_type, L, U);
d2e4a39e 11517 TYPE_NAME (type) = name;
14f9c5c9
AS
11518 return type;
11519 }
11520}
11521
4c4b4cd2
PH
11522/* True iff NAME is the name of a range type. */
11523
14f9c5c9 11524int
d2e4a39e 11525ada_is_range_type_name (const char *name)
14f9c5c9
AS
11526{
11527 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 11528}
14f9c5c9 11529\f
d2e4a39e 11530
4c4b4cd2
PH
11531 /* Modular types */
11532
11533/* True iff TYPE is an Ada modular type. */
14f9c5c9 11534
14f9c5c9 11535int
d2e4a39e 11536ada_is_modular_type (struct type *type)
14f9c5c9 11537{
18af8284 11538 struct type *subranged_type = get_base_type (type);
14f9c5c9
AS
11539
11540 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
690cc4eb 11541 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
4c4b4cd2 11542 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
11543}
11544
4c4b4cd2
PH
11545/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11546
61ee279c 11547ULONGEST
0056e4d5 11548ada_modulus (struct type *type)
14f9c5c9 11549{
43bbcdc2 11550 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 11551}
d2e4a39e 11552\f
f7f9143b
JB
11553
11554/* Ada exception catchpoint support:
11555 ---------------------------------
11556
11557 We support 3 kinds of exception catchpoints:
11558 . catchpoints on Ada exceptions
11559 . catchpoints on unhandled Ada exceptions
11560 . catchpoints on failed assertions
11561
11562 Exceptions raised during failed assertions, or unhandled exceptions
11563 could perfectly be caught with the general catchpoint on Ada exceptions.
11564 However, we can easily differentiate these two special cases, and having
11565 the option to distinguish these two cases from the rest can be useful
11566 to zero-in on certain situations.
11567
11568 Exception catchpoints are a specialized form of breakpoint,
11569 since they rely on inserting breakpoints inside known routines
11570 of the GNAT runtime. The implementation therefore uses a standard
11571 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11572 of breakpoint_ops.
11573
0259addd
JB
11574 Support in the runtime for exception catchpoints have been changed
11575 a few times already, and these changes affect the implementation
11576 of these catchpoints. In order to be able to support several
11577 variants of the runtime, we use a sniffer that will determine
28010a5d 11578 the runtime variant used by the program being debugged. */
f7f9143b 11579
82eacd52
JB
11580/* Ada's standard exceptions.
11581
11582 The Ada 83 standard also defined Numeric_Error. But there so many
11583 situations where it was unclear from the Ada 83 Reference Manual
11584 (RM) whether Constraint_Error or Numeric_Error should be raised,
11585 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11586 Interpretation saying that anytime the RM says that Numeric_Error
11587 should be raised, the implementation may raise Constraint_Error.
11588 Ada 95 went one step further and pretty much removed Numeric_Error
11589 from the list of standard exceptions (it made it a renaming of
11590 Constraint_Error, to help preserve compatibility when compiling
11591 an Ada83 compiler). As such, we do not include Numeric_Error from
11592 this list of standard exceptions. */
3d0b0fa3
JB
11593
11594static char *standard_exc[] = {
11595 "constraint_error",
11596 "program_error",
11597 "storage_error",
11598 "tasking_error"
11599};
11600
0259addd
JB
11601typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11602
11603/* A structure that describes how to support exception catchpoints
11604 for a given executable. */
11605
11606struct exception_support_info
11607{
11608 /* The name of the symbol to break on in order to insert
11609 a catchpoint on exceptions. */
11610 const char *catch_exception_sym;
11611
11612 /* The name of the symbol to break on in order to insert
11613 a catchpoint on unhandled exceptions. */
11614 const char *catch_exception_unhandled_sym;
11615
11616 /* The name of the symbol to break on in order to insert
11617 a catchpoint on failed assertions. */
11618 const char *catch_assert_sym;
11619
11620 /* Assuming that the inferior just triggered an unhandled exception
11621 catchpoint, this function is responsible for returning the address
11622 in inferior memory where the name of that exception is stored.
11623 Return zero if the address could not be computed. */
11624 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11625};
11626
11627static CORE_ADDR ada_unhandled_exception_name_addr (void);
11628static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11629
11630/* The following exception support info structure describes how to
11631 implement exception catchpoints with the latest version of the
11632 Ada runtime (as of 2007-03-06). */
11633
11634static const struct exception_support_info default_exception_support_info =
11635{
11636 "__gnat_debug_raise_exception", /* catch_exception_sym */
11637 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11638 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11639 ada_unhandled_exception_name_addr
11640};
11641
11642/* The following exception support info structure describes how to
11643 implement exception catchpoints with a slightly older version
11644 of the Ada runtime. */
11645
11646static const struct exception_support_info exception_support_info_fallback =
11647{
11648 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11649 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11650 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11651 ada_unhandled_exception_name_addr_from_raise
11652};
11653
f17011e0
JB
11654/* Return nonzero if we can detect the exception support routines
11655 described in EINFO.
11656
11657 This function errors out if an abnormal situation is detected
11658 (for instance, if we find the exception support routines, but
11659 that support is found to be incomplete). */
11660
11661static int
11662ada_has_this_exception_support (const struct exception_support_info *einfo)
11663{
11664 struct symbol *sym;
11665
11666 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11667 that should be compiled with debugging information. As a result, we
11668 expect to find that symbol in the symtabs. */
11669
11670 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11671 if (sym == NULL)
a6af7abe
JB
11672 {
11673 /* Perhaps we did not find our symbol because the Ada runtime was
11674 compiled without debugging info, or simply stripped of it.
11675 It happens on some GNU/Linux distributions for instance, where
11676 users have to install a separate debug package in order to get
11677 the runtime's debugging info. In that situation, let the user
11678 know why we cannot insert an Ada exception catchpoint.
11679
11680 Note: Just for the purpose of inserting our Ada exception
11681 catchpoint, we could rely purely on the associated minimal symbol.
11682 But we would be operating in degraded mode anyway, since we are
11683 still lacking the debugging info needed later on to extract
11684 the name of the exception being raised (this name is printed in
11685 the catchpoint message, and is also used when trying to catch
11686 a specific exception). We do not handle this case for now. */
3b7344d5 11687 struct bound_minimal_symbol msym
1c8e84b0
JB
11688 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11689
3b7344d5 11690 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
a6af7abe
JB
11691 error (_("Your Ada runtime appears to be missing some debugging "
11692 "information.\nCannot insert Ada exception catchpoint "
11693 "in this configuration."));
11694
11695 return 0;
11696 }
f17011e0
JB
11697
11698 /* Make sure that the symbol we found corresponds to a function. */
11699
11700 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11701 error (_("Symbol \"%s\" is not a function (class = %d)"),
11702 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11703
11704 return 1;
11705}
11706
0259addd
JB
11707/* Inspect the Ada runtime and determine which exception info structure
11708 should be used to provide support for exception catchpoints.
11709
3eecfa55
JB
11710 This function will always set the per-inferior exception_info,
11711 or raise an error. */
0259addd
JB
11712
11713static void
11714ada_exception_support_info_sniffer (void)
11715{
3eecfa55 11716 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
0259addd
JB
11717
11718 /* If the exception info is already known, then no need to recompute it. */
3eecfa55 11719 if (data->exception_info != NULL)
0259addd
JB
11720 return;
11721
11722 /* Check the latest (default) exception support info. */
f17011e0 11723 if (ada_has_this_exception_support (&default_exception_support_info))
0259addd 11724 {
3eecfa55 11725 data->exception_info = &default_exception_support_info;
0259addd
JB
11726 return;
11727 }
11728
11729 /* Try our fallback exception suport info. */
f17011e0 11730 if (ada_has_this_exception_support (&exception_support_info_fallback))
0259addd 11731 {
3eecfa55 11732 data->exception_info = &exception_support_info_fallback;
0259addd
JB
11733 return;
11734 }
11735
11736 /* Sometimes, it is normal for us to not be able to find the routine
11737 we are looking for. This happens when the program is linked with
11738 the shared version of the GNAT runtime, and the program has not been
11739 started yet. Inform the user of these two possible causes if
11740 applicable. */
11741
ccefe4c4 11742 if (ada_update_initial_language (language_unknown) != language_ada)
0259addd
JB
11743 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11744
11745 /* If the symbol does not exist, then check that the program is
11746 already started, to make sure that shared libraries have been
11747 loaded. If it is not started, this may mean that the symbol is
11748 in a shared library. */
11749
11750 if (ptid_get_pid (inferior_ptid) == 0)
11751 error (_("Unable to insert catchpoint. Try to start the program first."));
11752
11753 /* At this point, we know that we are debugging an Ada program and
11754 that the inferior has been started, but we still are not able to
0963b4bd 11755 find the run-time symbols. That can mean that we are in
0259addd
JB
11756 configurable run time mode, or that a-except as been optimized
11757 out by the linker... In any case, at this point it is not worth
11758 supporting this feature. */
11759
7dda8cff 11760 error (_("Cannot insert Ada exception catchpoints in this configuration."));
0259addd
JB
11761}
11762
f7f9143b
JB
11763/* True iff FRAME is very likely to be that of a function that is
11764 part of the runtime system. This is all very heuristic, but is
11765 intended to be used as advice as to what frames are uninteresting
11766 to most users. */
11767
11768static int
11769is_known_support_routine (struct frame_info *frame)
11770{
4ed6b5be 11771 struct symtab_and_line sal;
55b87a52 11772 char *func_name;
692465f1 11773 enum language func_lang;
f7f9143b 11774 int i;
f35a17b5 11775 const char *fullname;
f7f9143b 11776
4ed6b5be
JB
11777 /* If this code does not have any debugging information (no symtab),
11778 This cannot be any user code. */
f7f9143b 11779
4ed6b5be 11780 find_frame_sal (frame, &sal);
f7f9143b
JB
11781 if (sal.symtab == NULL)
11782 return 1;
11783
4ed6b5be
JB
11784 /* If there is a symtab, but the associated source file cannot be
11785 located, then assume this is not user code: Selecting a frame
11786 for which we cannot display the code would not be very helpful
11787 for the user. This should also take care of case such as VxWorks
11788 where the kernel has some debugging info provided for a few units. */
f7f9143b 11789
f35a17b5
JK
11790 fullname = symtab_to_fullname (sal.symtab);
11791 if (access (fullname, R_OK) != 0)
f7f9143b
JB
11792 return 1;
11793
4ed6b5be
JB
11794 /* Check the unit filename againt the Ada runtime file naming.
11795 We also check the name of the objfile against the name of some
11796 known system libraries that sometimes come with debugging info
11797 too. */
11798
f7f9143b
JB
11799 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11800 {
11801 re_comp (known_runtime_file_name_patterns[i]);
f69c91ad 11802 if (re_exec (lbasename (sal.symtab->filename)))
f7f9143b 11803 return 1;
eb822aa6
DE
11804 if (SYMTAB_OBJFILE (sal.symtab) != NULL
11805 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
4ed6b5be 11806 return 1;
f7f9143b
JB
11807 }
11808
4ed6b5be 11809 /* Check whether the function is a GNAT-generated entity. */
f7f9143b 11810
e9e07ba6 11811 find_frame_funname (frame, &func_name, &func_lang, NULL);
f7f9143b
JB
11812 if (func_name == NULL)
11813 return 1;
11814
11815 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11816 {
11817 re_comp (known_auxiliary_function_name_patterns[i]);
11818 if (re_exec (func_name))
55b87a52
KS
11819 {
11820 xfree (func_name);
11821 return 1;
11822 }
f7f9143b
JB
11823 }
11824
55b87a52 11825 xfree (func_name);
f7f9143b
JB
11826 return 0;
11827}
11828
11829/* Find the first frame that contains debugging information and that is not
11830 part of the Ada run-time, starting from FI and moving upward. */
11831
0ef643c8 11832void
f7f9143b
JB
11833ada_find_printable_frame (struct frame_info *fi)
11834{
11835 for (; fi != NULL; fi = get_prev_frame (fi))
11836 {
11837 if (!is_known_support_routine (fi))
11838 {
11839 select_frame (fi);
11840 break;
11841 }
11842 }
11843
11844}
11845
11846/* Assuming that the inferior just triggered an unhandled exception
11847 catchpoint, return the address in inferior memory where the name
11848 of the exception is stored.
11849
11850 Return zero if the address could not be computed. */
11851
11852static CORE_ADDR
11853ada_unhandled_exception_name_addr (void)
0259addd
JB
11854{
11855 return parse_and_eval_address ("e.full_name");
11856}
11857
11858/* Same as ada_unhandled_exception_name_addr, except that this function
11859 should be used when the inferior uses an older version of the runtime,
11860 where the exception name needs to be extracted from a specific frame
11861 several frames up in the callstack. */
11862
11863static CORE_ADDR
11864ada_unhandled_exception_name_addr_from_raise (void)
f7f9143b
JB
11865{
11866 int frame_level;
11867 struct frame_info *fi;
3eecfa55 11868 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
55b87a52 11869 struct cleanup *old_chain;
f7f9143b
JB
11870
11871 /* To determine the name of this exception, we need to select
11872 the frame corresponding to RAISE_SYM_NAME. This frame is
11873 at least 3 levels up, so we simply skip the first 3 frames
11874 without checking the name of their associated function. */
11875 fi = get_current_frame ();
11876 for (frame_level = 0; frame_level < 3; frame_level += 1)
11877 if (fi != NULL)
11878 fi = get_prev_frame (fi);
11879
55b87a52 11880 old_chain = make_cleanup (null_cleanup, NULL);
f7f9143b
JB
11881 while (fi != NULL)
11882 {
55b87a52 11883 char *func_name;
692465f1
JB
11884 enum language func_lang;
11885
e9e07ba6 11886 find_frame_funname (fi, &func_name, &func_lang, NULL);
55b87a52
KS
11887 if (func_name != NULL)
11888 {
11889 make_cleanup (xfree, func_name);
11890
11891 if (strcmp (func_name,
11892 data->exception_info->catch_exception_sym) == 0)
11893 break; /* We found the frame we were looking for... */
11894 fi = get_prev_frame (fi);
11895 }
f7f9143b 11896 }
55b87a52 11897 do_cleanups (old_chain);
f7f9143b
JB
11898
11899 if (fi == NULL)
11900 return 0;
11901
11902 select_frame (fi);
11903 return parse_and_eval_address ("id.full_name");
11904}
11905
11906/* Assuming the inferior just triggered an Ada exception catchpoint
11907 (of any type), return the address in inferior memory where the name
11908 of the exception is stored, if applicable.
11909
11910 Return zero if the address could not be computed, or if not relevant. */
11911
11912static CORE_ADDR
761269c8 11913ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11914 struct breakpoint *b)
11915{
3eecfa55
JB
11916 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11917
f7f9143b
JB
11918 switch (ex)
11919 {
761269c8 11920 case ada_catch_exception:
f7f9143b
JB
11921 return (parse_and_eval_address ("e.full_name"));
11922 break;
11923
761269c8 11924 case ada_catch_exception_unhandled:
3eecfa55 11925 return data->exception_info->unhandled_exception_name_addr ();
f7f9143b
JB
11926 break;
11927
761269c8 11928 case ada_catch_assert:
f7f9143b
JB
11929 return 0; /* Exception name is not relevant in this case. */
11930 break;
11931
11932 default:
11933 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11934 break;
11935 }
11936
11937 return 0; /* Should never be reached. */
11938}
11939
11940/* Same as ada_exception_name_addr_1, except that it intercepts and contains
11941 any error that ada_exception_name_addr_1 might cause to be thrown.
11942 When an error is intercepted, a warning with the error message is printed,
11943 and zero is returned. */
11944
11945static CORE_ADDR
761269c8 11946ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
11947 struct breakpoint *b)
11948{
f7f9143b
JB
11949 CORE_ADDR result = 0;
11950
492d29ea 11951 TRY
f7f9143b
JB
11952 {
11953 result = ada_exception_name_addr_1 (ex, b);
11954 }
11955
492d29ea 11956 CATCH (e, RETURN_MASK_ERROR)
f7f9143b
JB
11957 {
11958 warning (_("failed to get exception name: %s"), e.message);
11959 return 0;
11960 }
492d29ea 11961 END_CATCH
f7f9143b
JB
11962
11963 return result;
11964}
11965
28010a5d
PA
11966static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11967
11968/* Ada catchpoints.
11969
11970 In the case of catchpoints on Ada exceptions, the catchpoint will
11971 stop the target on every exception the program throws. When a user
11972 specifies the name of a specific exception, we translate this
11973 request into a condition expression (in text form), and then parse
11974 it into an expression stored in each of the catchpoint's locations.
11975 We then use this condition to check whether the exception that was
11976 raised is the one the user is interested in. If not, then the
11977 target is resumed again. We store the name of the requested
11978 exception, in order to be able to re-set the condition expression
11979 when symbols change. */
11980
11981/* An instance of this type is used to represent an Ada catchpoint
11982 breakpoint location. It includes a "struct bp_location" as a kind
11983 of base class; users downcast to "struct bp_location *" when
11984 needed. */
11985
11986struct ada_catchpoint_location
11987{
11988 /* The base class. */
11989 struct bp_location base;
11990
11991 /* The condition that checks whether the exception that was raised
11992 is the specific exception the user specified on catchpoint
11993 creation. */
11994 struct expression *excep_cond_expr;
11995};
11996
11997/* Implement the DTOR method in the bp_location_ops structure for all
11998 Ada exception catchpoint kinds. */
11999
12000static void
12001ada_catchpoint_location_dtor (struct bp_location *bl)
12002{
12003 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12004
12005 xfree (al->excep_cond_expr);
12006}
12007
12008/* The vtable to be used in Ada catchpoint locations. */
12009
12010static const struct bp_location_ops ada_catchpoint_location_ops =
12011{
12012 ada_catchpoint_location_dtor
12013};
12014
12015/* An instance of this type is used to represent an Ada catchpoint.
12016 It includes a "struct breakpoint" as a kind of base class; users
12017 downcast to "struct breakpoint *" when needed. */
12018
12019struct ada_catchpoint
12020{
12021 /* The base class. */
12022 struct breakpoint base;
12023
12024 /* The name of the specific exception the user specified. */
12025 char *excep_string;
12026};
12027
12028/* Parse the exception condition string in the context of each of the
12029 catchpoint's locations, and store them for later evaluation. */
12030
12031static void
12032create_excep_cond_exprs (struct ada_catchpoint *c)
12033{
12034 struct cleanup *old_chain;
12035 struct bp_location *bl;
12036 char *cond_string;
12037
12038 /* Nothing to do if there's no specific exception to catch. */
12039 if (c->excep_string == NULL)
12040 return;
12041
12042 /* Same if there are no locations... */
12043 if (c->base.loc == NULL)
12044 return;
12045
12046 /* Compute the condition expression in text form, from the specific
12047 expection we want to catch. */
12048 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
12049 old_chain = make_cleanup (xfree, cond_string);
12050
12051 /* Iterate over all the catchpoint's locations, and parse an
12052 expression for each. */
12053 for (bl = c->base.loc; bl != NULL; bl = bl->next)
12054 {
12055 struct ada_catchpoint_location *ada_loc
12056 = (struct ada_catchpoint_location *) bl;
12057 struct expression *exp = NULL;
12058
12059 if (!bl->shlib_disabled)
12060 {
bbc13ae3 12061 const char *s;
28010a5d
PA
12062
12063 s = cond_string;
492d29ea 12064 TRY
28010a5d 12065 {
1bb9788d
TT
12066 exp = parse_exp_1 (&s, bl->address,
12067 block_for_pc (bl->address), 0);
28010a5d 12068 }
492d29ea 12069 CATCH (e, RETURN_MASK_ERROR)
849f2b52
JB
12070 {
12071 warning (_("failed to reevaluate internal exception condition "
12072 "for catchpoint %d: %s"),
12073 c->base.number, e.message);
12074 /* There is a bug in GCC on sparc-solaris when building with
12075 optimization which causes EXP to change unexpectedly
12076 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
12077 The problem should be fixed starting with GCC 4.9.
12078 In the meantime, work around it by forcing EXP back
12079 to NULL. */
12080 exp = NULL;
12081 }
492d29ea 12082 END_CATCH
28010a5d
PA
12083 }
12084
12085 ada_loc->excep_cond_expr = exp;
12086 }
12087
12088 do_cleanups (old_chain);
12089}
12090
12091/* Implement the DTOR method in the breakpoint_ops structure for all
12092 exception catchpoint kinds. */
12093
12094static void
761269c8 12095dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12096{
12097 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12098
12099 xfree (c->excep_string);
348d480f 12100
2060206e 12101 bkpt_breakpoint_ops.dtor (b);
28010a5d
PA
12102}
12103
12104/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12105 structure for all exception catchpoint kinds. */
12106
12107static struct bp_location *
761269c8 12108allocate_location_exception (enum ada_exception_catchpoint_kind ex,
28010a5d
PA
12109 struct breakpoint *self)
12110{
12111 struct ada_catchpoint_location *loc;
12112
12113 loc = XNEW (struct ada_catchpoint_location);
12114 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
12115 loc->excep_cond_expr = NULL;
12116 return &loc->base;
12117}
12118
12119/* Implement the RE_SET method in the breakpoint_ops structure for all
12120 exception catchpoint kinds. */
12121
12122static void
761269c8 12123re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
28010a5d
PA
12124{
12125 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12126
12127 /* Call the base class's method. This updates the catchpoint's
12128 locations. */
2060206e 12129 bkpt_breakpoint_ops.re_set (b);
28010a5d
PA
12130
12131 /* Reparse the exception conditional expressions. One for each
12132 location. */
12133 create_excep_cond_exprs (c);
12134}
12135
12136/* Returns true if we should stop for this breakpoint hit. If the
12137 user specified a specific exception, we only want to cause a stop
12138 if the program thrown that exception. */
12139
12140static int
12141should_stop_exception (const struct bp_location *bl)
12142{
12143 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12144 const struct ada_catchpoint_location *ada_loc
12145 = (const struct ada_catchpoint_location *) bl;
28010a5d
PA
12146 int stop;
12147
12148 /* With no specific exception, should always stop. */
12149 if (c->excep_string == NULL)
12150 return 1;
12151
12152 if (ada_loc->excep_cond_expr == NULL)
12153 {
12154 /* We will have a NULL expression if back when we were creating
12155 the expressions, this location's had failed to parse. */
12156 return 1;
12157 }
12158
12159 stop = 1;
492d29ea 12160 TRY
28010a5d
PA
12161 {
12162 struct value *mark;
12163
12164 mark = value_mark ();
12165 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
12166 value_free_to_mark (mark);
12167 }
492d29ea
PA
12168 CATCH (ex, RETURN_MASK_ALL)
12169 {
12170 exception_fprintf (gdb_stderr, ex,
12171 _("Error in testing exception condition:\n"));
12172 }
12173 END_CATCH
12174
28010a5d
PA
12175 return stop;
12176}
12177
12178/* Implement the CHECK_STATUS method in the breakpoint_ops structure
12179 for all exception catchpoint kinds. */
12180
12181static void
761269c8 12182check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
28010a5d
PA
12183{
12184 bs->stop = should_stop_exception (bs->bp_location_at);
12185}
12186
f7f9143b
JB
12187/* Implement the PRINT_IT method in the breakpoint_ops structure
12188 for all exception catchpoint kinds. */
12189
12190static enum print_stop_action
761269c8 12191print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
f7f9143b 12192{
79a45e25 12193 struct ui_out *uiout = current_uiout;
348d480f
PA
12194 struct breakpoint *b = bs->breakpoint_at;
12195
956a9fb9 12196 annotate_catchpoint (b->number);
f7f9143b 12197
956a9fb9 12198 if (ui_out_is_mi_like_p (uiout))
f7f9143b 12199 {
956a9fb9
JB
12200 ui_out_field_string (uiout, "reason",
12201 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12202 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
f7f9143b
JB
12203 }
12204
00eb2c4a
JB
12205 ui_out_text (uiout,
12206 b->disposition == disp_del ? "\nTemporary catchpoint "
12207 : "\nCatchpoint ");
956a9fb9
JB
12208 ui_out_field_int (uiout, "bkptno", b->number);
12209 ui_out_text (uiout, ", ");
f7f9143b 12210
f7f9143b
JB
12211 switch (ex)
12212 {
761269c8
JB
12213 case ada_catch_exception:
12214 case ada_catch_exception_unhandled:
956a9fb9
JB
12215 {
12216 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12217 char exception_name[256];
12218
12219 if (addr != 0)
12220 {
c714b426
PA
12221 read_memory (addr, (gdb_byte *) exception_name,
12222 sizeof (exception_name) - 1);
956a9fb9
JB
12223 exception_name [sizeof (exception_name) - 1] = '\0';
12224 }
12225 else
12226 {
12227 /* For some reason, we were unable to read the exception
12228 name. This could happen if the Runtime was compiled
12229 without debugging info, for instance. In that case,
12230 just replace the exception name by the generic string
12231 "exception" - it will read as "an exception" in the
12232 notification we are about to print. */
967cff16 12233 memcpy (exception_name, "exception", sizeof ("exception"));
956a9fb9
JB
12234 }
12235 /* In the case of unhandled exception breakpoints, we print
12236 the exception name as "unhandled EXCEPTION_NAME", to make
12237 it clearer to the user which kind of catchpoint just got
12238 hit. We used ui_out_text to make sure that this extra
12239 info does not pollute the exception name in the MI case. */
761269c8 12240 if (ex == ada_catch_exception_unhandled)
956a9fb9
JB
12241 ui_out_text (uiout, "unhandled ");
12242 ui_out_field_string (uiout, "exception-name", exception_name);
12243 }
12244 break;
761269c8 12245 case ada_catch_assert:
956a9fb9
JB
12246 /* In this case, the name of the exception is not really
12247 important. Just print "failed assertion" to make it clearer
12248 that his program just hit an assertion-failure catchpoint.
12249 We used ui_out_text because this info does not belong in
12250 the MI output. */
12251 ui_out_text (uiout, "failed assertion");
12252 break;
f7f9143b 12253 }
956a9fb9
JB
12254 ui_out_text (uiout, " at ");
12255 ada_find_printable_frame (get_current_frame ());
f7f9143b
JB
12256
12257 return PRINT_SRC_AND_LOC;
12258}
12259
12260/* Implement the PRINT_ONE method in the breakpoint_ops structure
12261 for all exception catchpoint kinds. */
12262
12263static void
761269c8 12264print_one_exception (enum ada_exception_catchpoint_kind ex,
a6d9a66e 12265 struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12266{
79a45e25 12267 struct ui_out *uiout = current_uiout;
28010a5d 12268 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45b7d
TT
12269 struct value_print_options opts;
12270
12271 get_user_print_options (&opts);
12272 if (opts.addressprint)
f7f9143b
JB
12273 {
12274 annotate_field (4);
5af949e3 12275 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
f7f9143b
JB
12276 }
12277
12278 annotate_field (5);
a6d9a66e 12279 *last_loc = b->loc;
f7f9143b
JB
12280 switch (ex)
12281 {
761269c8 12282 case ada_catch_exception:
28010a5d 12283 if (c->excep_string != NULL)
f7f9143b 12284 {
28010a5d
PA
12285 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12286
f7f9143b
JB
12287 ui_out_field_string (uiout, "what", msg);
12288 xfree (msg);
12289 }
12290 else
12291 ui_out_field_string (uiout, "what", "all Ada exceptions");
12292
12293 break;
12294
761269c8 12295 case ada_catch_exception_unhandled:
f7f9143b
JB
12296 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
12297 break;
12298
761269c8 12299 case ada_catch_assert:
f7f9143b
JB
12300 ui_out_field_string (uiout, "what", "failed Ada assertions");
12301 break;
12302
12303 default:
12304 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12305 break;
12306 }
12307}
12308
12309/* Implement the PRINT_MENTION method in the breakpoint_ops structure
12310 for all exception catchpoint kinds. */
12311
12312static void
761269c8 12313print_mention_exception (enum ada_exception_catchpoint_kind ex,
f7f9143b
JB
12314 struct breakpoint *b)
12315{
28010a5d 12316 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
79a45e25 12317 struct ui_out *uiout = current_uiout;
28010a5d 12318
00eb2c4a
JB
12319 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
12320 : _("Catchpoint "));
12321 ui_out_field_int (uiout, "bkptno", b->number);
12322 ui_out_text (uiout, ": ");
12323
f7f9143b
JB
12324 switch (ex)
12325 {
761269c8 12326 case ada_catch_exception:
28010a5d 12327 if (c->excep_string != NULL)
00eb2c4a
JB
12328 {
12329 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12330 struct cleanup *old_chain = make_cleanup (xfree, info);
12331
12332 ui_out_text (uiout, info);
12333 do_cleanups (old_chain);
12334 }
f7f9143b 12335 else
00eb2c4a 12336 ui_out_text (uiout, _("all Ada exceptions"));
f7f9143b
JB
12337 break;
12338
761269c8 12339 case ada_catch_exception_unhandled:
00eb2c4a 12340 ui_out_text (uiout, _("unhandled Ada exceptions"));
f7f9143b
JB
12341 break;
12342
761269c8 12343 case ada_catch_assert:
00eb2c4a 12344 ui_out_text (uiout, _("failed Ada assertions"));
f7f9143b
JB
12345 break;
12346
12347 default:
12348 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12349 break;
12350 }
12351}
12352
6149aea9
PA
12353/* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12354 for all exception catchpoint kinds. */
12355
12356static void
761269c8 12357print_recreate_exception (enum ada_exception_catchpoint_kind ex,
6149aea9
PA
12358 struct breakpoint *b, struct ui_file *fp)
12359{
28010a5d
PA
12360 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12361
6149aea9
PA
12362 switch (ex)
12363 {
761269c8 12364 case ada_catch_exception:
6149aea9 12365 fprintf_filtered (fp, "catch exception");
28010a5d
PA
12366 if (c->excep_string != NULL)
12367 fprintf_filtered (fp, " %s", c->excep_string);
6149aea9
PA
12368 break;
12369
761269c8 12370 case ada_catch_exception_unhandled:
78076abc 12371 fprintf_filtered (fp, "catch exception unhandled");
6149aea9
PA
12372 break;
12373
761269c8 12374 case ada_catch_assert:
6149aea9
PA
12375 fprintf_filtered (fp, "catch assert");
12376 break;
12377
12378 default:
12379 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12380 }
d9b3f62e 12381 print_recreate_thread (b, fp);
6149aea9
PA
12382}
12383
f7f9143b
JB
12384/* Virtual table for "catch exception" breakpoints. */
12385
28010a5d
PA
12386static void
12387dtor_catch_exception (struct breakpoint *b)
12388{
761269c8 12389 dtor_exception (ada_catch_exception, b);
28010a5d
PA
12390}
12391
12392static struct bp_location *
12393allocate_location_catch_exception (struct breakpoint *self)
12394{
761269c8 12395 return allocate_location_exception (ada_catch_exception, self);
28010a5d
PA
12396}
12397
12398static void
12399re_set_catch_exception (struct breakpoint *b)
12400{
761269c8 12401 re_set_exception (ada_catch_exception, b);
28010a5d
PA
12402}
12403
12404static void
12405check_status_catch_exception (bpstat bs)
12406{
761269c8 12407 check_status_exception (ada_catch_exception, bs);
28010a5d
PA
12408}
12409
f7f9143b 12410static enum print_stop_action
348d480f 12411print_it_catch_exception (bpstat bs)
f7f9143b 12412{
761269c8 12413 return print_it_exception (ada_catch_exception, bs);
f7f9143b
JB
12414}
12415
12416static void
a6d9a66e 12417print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12418{
761269c8 12419 print_one_exception (ada_catch_exception, b, last_loc);
f7f9143b
JB
12420}
12421
12422static void
12423print_mention_catch_exception (struct breakpoint *b)
12424{
761269c8 12425 print_mention_exception (ada_catch_exception, b);
f7f9143b
JB
12426}
12427
6149aea9
PA
12428static void
12429print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12430{
761269c8 12431 print_recreate_exception (ada_catch_exception, b, fp);
6149aea9
PA
12432}
12433
2060206e 12434static struct breakpoint_ops catch_exception_breakpoint_ops;
f7f9143b
JB
12435
12436/* Virtual table for "catch exception unhandled" breakpoints. */
12437
28010a5d
PA
12438static void
12439dtor_catch_exception_unhandled (struct breakpoint *b)
12440{
761269c8 12441 dtor_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12442}
12443
12444static struct bp_location *
12445allocate_location_catch_exception_unhandled (struct breakpoint *self)
12446{
761269c8 12447 return allocate_location_exception (ada_catch_exception_unhandled, self);
28010a5d
PA
12448}
12449
12450static void
12451re_set_catch_exception_unhandled (struct breakpoint *b)
12452{
761269c8 12453 re_set_exception (ada_catch_exception_unhandled, b);
28010a5d
PA
12454}
12455
12456static void
12457check_status_catch_exception_unhandled (bpstat bs)
12458{
761269c8 12459 check_status_exception (ada_catch_exception_unhandled, bs);
28010a5d
PA
12460}
12461
f7f9143b 12462static enum print_stop_action
348d480f 12463print_it_catch_exception_unhandled (bpstat bs)
f7f9143b 12464{
761269c8 12465 return print_it_exception (ada_catch_exception_unhandled, bs);
f7f9143b
JB
12466}
12467
12468static void
a6d9a66e
UW
12469print_one_catch_exception_unhandled (struct breakpoint *b,
12470 struct bp_location **last_loc)
f7f9143b 12471{
761269c8 12472 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
f7f9143b
JB
12473}
12474
12475static void
12476print_mention_catch_exception_unhandled (struct breakpoint *b)
12477{
761269c8 12478 print_mention_exception (ada_catch_exception_unhandled, b);
f7f9143b
JB
12479}
12480
6149aea9
PA
12481static void
12482print_recreate_catch_exception_unhandled (struct breakpoint *b,
12483 struct ui_file *fp)
12484{
761269c8 12485 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
6149aea9
PA
12486}
12487
2060206e 12488static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
f7f9143b
JB
12489
12490/* Virtual table for "catch assert" breakpoints. */
12491
28010a5d
PA
12492static void
12493dtor_catch_assert (struct breakpoint *b)
12494{
761269c8 12495 dtor_exception (ada_catch_assert, b);
28010a5d
PA
12496}
12497
12498static struct bp_location *
12499allocate_location_catch_assert (struct breakpoint *self)
12500{
761269c8 12501 return allocate_location_exception (ada_catch_assert, self);
28010a5d
PA
12502}
12503
12504static void
12505re_set_catch_assert (struct breakpoint *b)
12506{
761269c8 12507 re_set_exception (ada_catch_assert, b);
28010a5d
PA
12508}
12509
12510static void
12511check_status_catch_assert (bpstat bs)
12512{
761269c8 12513 check_status_exception (ada_catch_assert, bs);
28010a5d
PA
12514}
12515
f7f9143b 12516static enum print_stop_action
348d480f 12517print_it_catch_assert (bpstat bs)
f7f9143b 12518{
761269c8 12519 return print_it_exception (ada_catch_assert, bs);
f7f9143b
JB
12520}
12521
12522static void
a6d9a66e 12523print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
f7f9143b 12524{
761269c8 12525 print_one_exception (ada_catch_assert, b, last_loc);
f7f9143b
JB
12526}
12527
12528static void
12529print_mention_catch_assert (struct breakpoint *b)
12530{
761269c8 12531 print_mention_exception (ada_catch_assert, b);
f7f9143b
JB
12532}
12533
6149aea9
PA
12534static void
12535print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12536{
761269c8 12537 print_recreate_exception (ada_catch_assert, b, fp);
6149aea9
PA
12538}
12539
2060206e 12540static struct breakpoint_ops catch_assert_breakpoint_ops;
f7f9143b 12541
f7f9143b
JB
12542/* Return a newly allocated copy of the first space-separated token
12543 in ARGSP, and then adjust ARGSP to point immediately after that
12544 token.
12545
12546 Return NULL if ARGPS does not contain any more tokens. */
12547
12548static char *
12549ada_get_next_arg (char **argsp)
12550{
12551 char *args = *argsp;
12552 char *end;
12553 char *result;
12554
0fcd72ba 12555 args = skip_spaces (args);
f7f9143b
JB
12556 if (args[0] == '\0')
12557 return NULL; /* No more arguments. */
12558
12559 /* Find the end of the current argument. */
12560
0fcd72ba 12561 end = skip_to_space (args);
f7f9143b
JB
12562
12563 /* Adjust ARGSP to point to the start of the next argument. */
12564
12565 *argsp = end;
12566
12567 /* Make a copy of the current argument and return it. */
12568
12569 result = xmalloc (end - args + 1);
12570 strncpy (result, args, end - args);
12571 result[end - args] = '\0';
12572
12573 return result;
12574}
12575
12576/* Split the arguments specified in a "catch exception" command.
12577 Set EX to the appropriate catchpoint type.
28010a5d 12578 Set EXCEP_STRING to the name of the specific exception if
5845583d
JB
12579 specified by the user.
12580 If a condition is found at the end of the arguments, the condition
12581 expression is stored in COND_STRING (memory must be deallocated
12582 after use). Otherwise COND_STRING is set to NULL. */
f7f9143b
JB
12583
12584static void
12585catch_ada_exception_command_split (char *args,
761269c8 12586 enum ada_exception_catchpoint_kind *ex,
5845583d
JB
12587 char **excep_string,
12588 char **cond_string)
f7f9143b
JB
12589{
12590 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12591 char *exception_name;
5845583d 12592 char *cond = NULL;
f7f9143b
JB
12593
12594 exception_name = ada_get_next_arg (&args);
5845583d
JB
12595 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12596 {
12597 /* This is not an exception name; this is the start of a condition
12598 expression for a catchpoint on all exceptions. So, "un-get"
12599 this token, and set exception_name to NULL. */
12600 xfree (exception_name);
12601 exception_name = NULL;
12602 args -= 2;
12603 }
f7f9143b
JB
12604 make_cleanup (xfree, exception_name);
12605
5845583d 12606 /* Check to see if we have a condition. */
f7f9143b 12607
0fcd72ba 12608 args = skip_spaces (args);
61012eef 12609 if (startswith (args, "if")
5845583d
JB
12610 && (isspace (args[2]) || args[2] == '\0'))
12611 {
12612 args += 2;
12613 args = skip_spaces (args);
12614
12615 if (args[0] == '\0')
12616 error (_("Condition missing after `if' keyword"));
12617 cond = xstrdup (args);
12618 make_cleanup (xfree, cond);
12619
12620 args += strlen (args);
12621 }
12622
12623 /* Check that we do not have any more arguments. Anything else
12624 is unexpected. */
f7f9143b
JB
12625
12626 if (args[0] != '\0')
12627 error (_("Junk at end of expression"));
12628
12629 discard_cleanups (old_chain);
12630
12631 if (exception_name == NULL)
12632 {
12633 /* Catch all exceptions. */
761269c8 12634 *ex = ada_catch_exception;
28010a5d 12635 *excep_string = NULL;
f7f9143b
JB
12636 }
12637 else if (strcmp (exception_name, "unhandled") == 0)
12638 {
12639 /* Catch unhandled exceptions. */
761269c8 12640 *ex = ada_catch_exception_unhandled;
28010a5d 12641 *excep_string = NULL;
f7f9143b
JB
12642 }
12643 else
12644 {
12645 /* Catch a specific exception. */
761269c8 12646 *ex = ada_catch_exception;
28010a5d 12647 *excep_string = exception_name;
f7f9143b 12648 }
5845583d 12649 *cond_string = cond;
f7f9143b
JB
12650}
12651
12652/* Return the name of the symbol on which we should break in order to
12653 implement a catchpoint of the EX kind. */
12654
12655static const char *
761269c8 12656ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
f7f9143b 12657{
3eecfa55
JB
12658 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12659
12660 gdb_assert (data->exception_info != NULL);
0259addd 12661
f7f9143b
JB
12662 switch (ex)
12663 {
761269c8 12664 case ada_catch_exception:
3eecfa55 12665 return (data->exception_info->catch_exception_sym);
f7f9143b 12666 break;
761269c8 12667 case ada_catch_exception_unhandled:
3eecfa55 12668 return (data->exception_info->catch_exception_unhandled_sym);
f7f9143b 12669 break;
761269c8 12670 case ada_catch_assert:
3eecfa55 12671 return (data->exception_info->catch_assert_sym);
f7f9143b
JB
12672 break;
12673 default:
12674 internal_error (__FILE__, __LINE__,
12675 _("unexpected catchpoint kind (%d)"), ex);
12676 }
12677}
12678
12679/* Return the breakpoint ops "virtual table" used for catchpoints
12680 of the EX kind. */
12681
c0a91b2b 12682static const struct breakpoint_ops *
761269c8 12683ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
f7f9143b
JB
12684{
12685 switch (ex)
12686 {
761269c8 12687 case ada_catch_exception:
f7f9143b
JB
12688 return (&catch_exception_breakpoint_ops);
12689 break;
761269c8 12690 case ada_catch_exception_unhandled:
f7f9143b
JB
12691 return (&catch_exception_unhandled_breakpoint_ops);
12692 break;
761269c8 12693 case ada_catch_assert:
f7f9143b
JB
12694 return (&catch_assert_breakpoint_ops);
12695 break;
12696 default:
12697 internal_error (__FILE__, __LINE__,
12698 _("unexpected catchpoint kind (%d)"), ex);
12699 }
12700}
12701
12702/* Return the condition that will be used to match the current exception
12703 being raised with the exception that the user wants to catch. This
12704 assumes that this condition is used when the inferior just triggered
12705 an exception catchpoint.
12706
12707 The string returned is a newly allocated string that needs to be
12708 deallocated later. */
12709
12710static char *
28010a5d 12711ada_exception_catchpoint_cond_string (const char *excep_string)
f7f9143b 12712{
3d0b0fa3
JB
12713 int i;
12714
0963b4bd 12715 /* The standard exceptions are a special case. They are defined in
3d0b0fa3 12716 runtime units that have been compiled without debugging info; if
28010a5d 12717 EXCEP_STRING is the not-fully-qualified name of a standard
3d0b0fa3
JB
12718 exception (e.g. "constraint_error") then, during the evaluation
12719 of the condition expression, the symbol lookup on this name would
0963b4bd 12720 *not* return this standard exception. The catchpoint condition
3d0b0fa3
JB
12721 may then be set only on user-defined exceptions which have the
12722 same not-fully-qualified name (e.g. my_package.constraint_error).
12723
12724 To avoid this unexcepted behavior, these standard exceptions are
0963b4bd 12725 systematically prefixed by "standard". This means that "catch
3d0b0fa3
JB
12726 exception constraint_error" is rewritten into "catch exception
12727 standard.constraint_error".
12728
12729 If an exception named contraint_error is defined in another package of
12730 the inferior program, then the only way to specify this exception as a
12731 breakpoint condition is to use its fully-qualified named:
12732 e.g. my_package.constraint_error. */
12733
12734 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12735 {
28010a5d 12736 if (strcmp (standard_exc [i], excep_string) == 0)
3d0b0fa3
JB
12737 {
12738 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
28010a5d 12739 excep_string);
3d0b0fa3
JB
12740 }
12741 }
28010a5d 12742 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
f7f9143b
JB
12743}
12744
12745/* Return the symtab_and_line that should be used to insert an exception
12746 catchpoint of the TYPE kind.
12747
28010a5d
PA
12748 EXCEP_STRING should contain the name of a specific exception that
12749 the catchpoint should catch, or NULL otherwise.
f7f9143b 12750
28010a5d
PA
12751 ADDR_STRING returns the name of the function where the real
12752 breakpoint that implements the catchpoints is set, depending on the
12753 type of catchpoint we need to create. */
f7f9143b
JB
12754
12755static struct symtab_and_line
761269c8 12756ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
c0a91b2b 12757 char **addr_string, const struct breakpoint_ops **ops)
f7f9143b
JB
12758{
12759 const char *sym_name;
12760 struct symbol *sym;
f7f9143b 12761
0259addd
JB
12762 /* First, find out which exception support info to use. */
12763 ada_exception_support_info_sniffer ();
12764
12765 /* Then lookup the function on which we will break in order to catch
f7f9143b 12766 the Ada exceptions requested by the user. */
f7f9143b
JB
12767 sym_name = ada_exception_sym_name (ex);
12768 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12769
f17011e0
JB
12770 /* We can assume that SYM is not NULL at this stage. If the symbol
12771 did not exist, ada_exception_support_info_sniffer would have
12772 raised an exception.
f7f9143b 12773
f17011e0
JB
12774 Also, ada_exception_support_info_sniffer should have already
12775 verified that SYM is a function symbol. */
12776 gdb_assert (sym != NULL);
12777 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
f7f9143b
JB
12778
12779 /* Set ADDR_STRING. */
f7f9143b
JB
12780 *addr_string = xstrdup (sym_name);
12781
f7f9143b 12782 /* Set OPS. */
4b9eee8c 12783 *ops = ada_exception_breakpoint_ops (ex);
f7f9143b 12784
f17011e0 12785 return find_function_start_sal (sym, 1);
f7f9143b
JB
12786}
12787
b4a5b78b 12788/* Create an Ada exception catchpoint.
f7f9143b 12789
b4a5b78b 12790 EX_KIND is the kind of exception catchpoint to be created.
5845583d 12791
2df4d1d5
JB
12792 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12793 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12794 of the exception to which this catchpoint applies. When not NULL,
12795 the string must be allocated on the heap, and its deallocation
12796 is no longer the responsibility of the caller.
12797
12798 COND_STRING, if not NULL, is the catchpoint condition. This string
12799 must be allocated on the heap, and its deallocation is no longer
12800 the responsibility of the caller.
f7f9143b 12801
b4a5b78b
JB
12802 TEMPFLAG, if nonzero, means that the underlying breakpoint
12803 should be temporary.
28010a5d 12804
b4a5b78b 12805 FROM_TTY is the usual argument passed to all commands implementations. */
28010a5d 12806
349774ef 12807void
28010a5d 12808create_ada_exception_catchpoint (struct gdbarch *gdbarch,
761269c8 12809 enum ada_exception_catchpoint_kind ex_kind,
28010a5d 12810 char *excep_string,
5845583d 12811 char *cond_string,
28010a5d 12812 int tempflag,
349774ef 12813 int disabled,
28010a5d
PA
12814 int from_tty)
12815{
12816 struct ada_catchpoint *c;
b4a5b78b
JB
12817 char *addr_string = NULL;
12818 const struct breakpoint_ops *ops = NULL;
12819 struct symtab_and_line sal
12820 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
28010a5d
PA
12821
12822 c = XNEW (struct ada_catchpoint);
12823 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
349774ef 12824 ops, tempflag, disabled, from_tty);
28010a5d
PA
12825 c->excep_string = excep_string;
12826 create_excep_cond_exprs (c);
5845583d
JB
12827 if (cond_string != NULL)
12828 set_breakpoint_condition (&c->base, cond_string, from_tty);
3ea46bff 12829 install_breakpoint (0, &c->base, 1);
f7f9143b
JB
12830}
12831
9ac4176b
PA
12832/* Implement the "catch exception" command. */
12833
12834static void
12835catch_ada_exception_command (char *arg, int from_tty,
12836 struct cmd_list_element *command)
12837{
12838 struct gdbarch *gdbarch = get_current_arch ();
12839 int tempflag;
761269c8 12840 enum ada_exception_catchpoint_kind ex_kind;
28010a5d 12841 char *excep_string = NULL;
5845583d 12842 char *cond_string = NULL;
9ac4176b
PA
12843
12844 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12845
12846 if (!arg)
12847 arg = "";
b4a5b78b
JB
12848 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12849 &cond_string);
12850 create_ada_exception_catchpoint (gdbarch, ex_kind,
12851 excep_string, cond_string,
349774ef
JB
12852 tempflag, 1 /* enabled */,
12853 from_tty);
9ac4176b
PA
12854}
12855
b4a5b78b 12856/* Split the arguments specified in a "catch assert" command.
5845583d 12857
b4a5b78b
JB
12858 ARGS contains the command's arguments (or the empty string if
12859 no arguments were passed).
5845583d
JB
12860
12861 If ARGS contains a condition, set COND_STRING to that condition
b4a5b78b 12862 (the memory needs to be deallocated after use). */
5845583d 12863
b4a5b78b
JB
12864static void
12865catch_ada_assert_command_split (char *args, char **cond_string)
f7f9143b 12866{
5845583d 12867 args = skip_spaces (args);
f7f9143b 12868
5845583d 12869 /* Check whether a condition was provided. */
61012eef 12870 if (startswith (args, "if")
5845583d 12871 && (isspace (args[2]) || args[2] == '\0'))
f7f9143b 12872 {
5845583d 12873 args += 2;
0fcd72ba 12874 args = skip_spaces (args);
5845583d
JB
12875 if (args[0] == '\0')
12876 error (_("condition missing after `if' keyword"));
12877 *cond_string = xstrdup (args);
f7f9143b
JB
12878 }
12879
5845583d
JB
12880 /* Otherwise, there should be no other argument at the end of
12881 the command. */
12882 else if (args[0] != '\0')
12883 error (_("Junk at end of arguments."));
f7f9143b
JB
12884}
12885
9ac4176b
PA
12886/* Implement the "catch assert" command. */
12887
12888static void
12889catch_assert_command (char *arg, int from_tty,
12890 struct cmd_list_element *command)
12891{
12892 struct gdbarch *gdbarch = get_current_arch ();
12893 int tempflag;
5845583d 12894 char *cond_string = NULL;
9ac4176b
PA
12895
12896 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12897
12898 if (!arg)
12899 arg = "";
b4a5b78b 12900 catch_ada_assert_command_split (arg, &cond_string);
761269c8 12901 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
b4a5b78b 12902 NULL, cond_string,
349774ef
JB
12903 tempflag, 1 /* enabled */,
12904 from_tty);
9ac4176b 12905}
778865d3
JB
12906
12907/* Return non-zero if the symbol SYM is an Ada exception object. */
12908
12909static int
12910ada_is_exception_sym (struct symbol *sym)
12911{
12912 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12913
12914 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12915 && SYMBOL_CLASS (sym) != LOC_BLOCK
12916 && SYMBOL_CLASS (sym) != LOC_CONST
12917 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12918 && type_name != NULL && strcmp (type_name, "exception") == 0);
12919}
12920
12921/* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12922 Ada exception object. This matches all exceptions except the ones
12923 defined by the Ada language. */
12924
12925static int
12926ada_is_non_standard_exception_sym (struct symbol *sym)
12927{
12928 int i;
12929
12930 if (!ada_is_exception_sym (sym))
12931 return 0;
12932
12933 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12934 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12935 return 0; /* A standard exception. */
12936
12937 /* Numeric_Error is also a standard exception, so exclude it.
12938 See the STANDARD_EXC description for more details as to why
12939 this exception is not listed in that array. */
12940 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12941 return 0;
12942
12943 return 1;
12944}
12945
12946/* A helper function for qsort, comparing two struct ada_exc_info
12947 objects.
12948
12949 The comparison is determined first by exception name, and then
12950 by exception address. */
12951
12952static int
12953compare_ada_exception_info (const void *a, const void *b)
12954{
12955 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12956 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12957 int result;
12958
12959 result = strcmp (exc_a->name, exc_b->name);
12960 if (result != 0)
12961 return result;
12962
12963 if (exc_a->addr < exc_b->addr)
12964 return -1;
12965 if (exc_a->addr > exc_b->addr)
12966 return 1;
12967
12968 return 0;
12969}
12970
12971/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12972 routine, but keeping the first SKIP elements untouched.
12973
12974 All duplicates are also removed. */
12975
12976static void
12977sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12978 int skip)
12979{
12980 struct ada_exc_info *to_sort
12981 = VEC_address (ada_exc_info, *exceptions) + skip;
12982 int to_sort_len
12983 = VEC_length (ada_exc_info, *exceptions) - skip;
12984 int i, j;
12985
12986 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12987 compare_ada_exception_info);
12988
12989 for (i = 1, j = 1; i < to_sort_len; i++)
12990 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12991 to_sort[j++] = to_sort[i];
12992 to_sort_len = j;
12993 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12994}
12995
12996/* A function intended as the "name_matcher" callback in the struct
12997 quick_symbol_functions' expand_symtabs_matching method.
12998
12999 SEARCH_NAME is the symbol's search name.
13000
13001 If USER_DATA is not NULL, it is a pointer to a regext_t object
13002 used to match the symbol (by natural name). Otherwise, when USER_DATA
13003 is null, no filtering is performed, and all symbols are a positive
13004 match. */
13005
13006static int
13007ada_exc_search_name_matches (const char *search_name, void *user_data)
13008{
13009 regex_t *preg = user_data;
13010
13011 if (preg == NULL)
13012 return 1;
13013
13014 /* In Ada, the symbol "search name" is a linkage name, whereas
13015 the regular expression used to do the matching refers to
13016 the natural name. So match against the decoded name. */
13017 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
13018}
13019
13020/* Add all exceptions defined by the Ada standard whose name match
13021 a regular expression.
13022
13023 If PREG is not NULL, then this regexp_t object is used to
13024 perform the symbol name matching. Otherwise, no name-based
13025 filtering is performed.
13026
13027 EXCEPTIONS is a vector of exceptions to which matching exceptions
13028 gets pushed. */
13029
13030static void
13031ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
13032{
13033 int i;
13034
13035 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13036 {
13037 if (preg == NULL
13038 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
13039 {
13040 struct bound_minimal_symbol msymbol
13041 = ada_lookup_simple_minsym (standard_exc[i]);
13042
13043 if (msymbol.minsym != NULL)
13044 {
13045 struct ada_exc_info info
77e371c0 13046 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
778865d3
JB
13047
13048 VEC_safe_push (ada_exc_info, *exceptions, &info);
13049 }
13050 }
13051 }
13052}
13053
13054/* Add all Ada exceptions defined locally and accessible from the given
13055 FRAME.
13056
13057 If PREG is not NULL, then this regexp_t object is used to
13058 perform the symbol name matching. Otherwise, no name-based
13059 filtering is performed.
13060
13061 EXCEPTIONS is a vector of exceptions to which matching exceptions
13062 gets pushed. */
13063
13064static void
13065ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
13066 VEC(ada_exc_info) **exceptions)
13067{
3977b71f 13068 const struct block *block = get_frame_block (frame, 0);
778865d3
JB
13069
13070 while (block != 0)
13071 {
13072 struct block_iterator iter;
13073 struct symbol *sym;
13074
13075 ALL_BLOCK_SYMBOLS (block, iter, sym)
13076 {
13077 switch (SYMBOL_CLASS (sym))
13078 {
13079 case LOC_TYPEDEF:
13080 case LOC_BLOCK:
13081 case LOC_CONST:
13082 break;
13083 default:
13084 if (ada_is_exception_sym (sym))
13085 {
13086 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13087 SYMBOL_VALUE_ADDRESS (sym)};
13088
13089 VEC_safe_push (ada_exc_info, *exceptions, &info);
13090 }
13091 }
13092 }
13093 if (BLOCK_FUNCTION (block) != NULL)
13094 break;
13095 block = BLOCK_SUPERBLOCK (block);
13096 }
13097}
13098
13099/* Add all exceptions defined globally whose name name match
13100 a regular expression, excluding standard exceptions.
13101
13102 The reason we exclude standard exceptions is that they need
13103 to be handled separately: Standard exceptions are defined inside
13104 a runtime unit which is normally not compiled with debugging info,
13105 and thus usually do not show up in our symbol search. However,
13106 if the unit was in fact built with debugging info, we need to
13107 exclude them because they would duplicate the entry we found
13108 during the special loop that specifically searches for those
13109 standard exceptions.
13110
13111 If PREG is not NULL, then this regexp_t object is used to
13112 perform the symbol name matching. Otherwise, no name-based
13113 filtering is performed.
13114
13115 EXCEPTIONS is a vector of exceptions to which matching exceptions
13116 gets pushed. */
13117
13118static void
13119ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
13120{
13121 struct objfile *objfile;
43f3e411 13122 struct compunit_symtab *s;
778865d3 13123
276d885b 13124 expand_symtabs_matching (NULL, ada_exc_search_name_matches, NULL,
bb4142cf 13125 VARIABLES_DOMAIN, preg);
778865d3 13126
43f3e411 13127 ALL_COMPUNITS (objfile, s)
778865d3 13128 {
43f3e411 13129 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
778865d3
JB
13130 int i;
13131
13132 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13133 {
13134 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13135 struct block_iterator iter;
13136 struct symbol *sym;
13137
13138 ALL_BLOCK_SYMBOLS (b, iter, sym)
13139 if (ada_is_non_standard_exception_sym (sym)
13140 && (preg == NULL
13141 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
13142 0, NULL, 0) == 0))
13143 {
13144 struct ada_exc_info info
13145 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13146
13147 VEC_safe_push (ada_exc_info, *exceptions, &info);
13148 }
13149 }
13150 }
13151}
13152
13153/* Implements ada_exceptions_list with the regular expression passed
13154 as a regex_t, rather than a string.
13155
13156 If not NULL, PREG is used to filter out exceptions whose names
13157 do not match. Otherwise, all exceptions are listed. */
13158
13159static VEC(ada_exc_info) *
13160ada_exceptions_list_1 (regex_t *preg)
13161{
13162 VEC(ada_exc_info) *result = NULL;
13163 struct cleanup *old_chain
13164 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
13165 int prev_len;
13166
13167 /* First, list the known standard exceptions. These exceptions
13168 need to be handled separately, as they are usually defined in
13169 runtime units that have been compiled without debugging info. */
13170
13171 ada_add_standard_exceptions (preg, &result);
13172
13173 /* Next, find all exceptions whose scope is local and accessible
13174 from the currently selected frame. */
13175
13176 if (has_stack_frames ())
13177 {
13178 prev_len = VEC_length (ada_exc_info, result);
13179 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13180 &result);
13181 if (VEC_length (ada_exc_info, result) > prev_len)
13182 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13183 }
13184
13185 /* Add all exceptions whose scope is global. */
13186
13187 prev_len = VEC_length (ada_exc_info, result);
13188 ada_add_global_exceptions (preg, &result);
13189 if (VEC_length (ada_exc_info, result) > prev_len)
13190 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13191
13192 discard_cleanups (old_chain);
13193 return result;
13194}
13195
13196/* Return a vector of ada_exc_info.
13197
13198 If REGEXP is NULL, all exceptions are included in the result.
13199 Otherwise, it should contain a valid regular expression,
13200 and only the exceptions whose names match that regular expression
13201 are included in the result.
13202
13203 The exceptions are sorted in the following order:
13204 - Standard exceptions (defined by the Ada language), in
13205 alphabetical order;
13206 - Exceptions only visible from the current frame, in
13207 alphabetical order;
13208 - Exceptions whose scope is global, in alphabetical order. */
13209
13210VEC(ada_exc_info) *
13211ada_exceptions_list (const char *regexp)
13212{
13213 VEC(ada_exc_info) *result = NULL;
13214 struct cleanup *old_chain = NULL;
13215 regex_t reg;
13216
13217 if (regexp != NULL)
13218 old_chain = compile_rx_or_error (&reg, regexp,
13219 _("invalid regular expression"));
13220
13221 result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
13222
13223 if (old_chain != NULL)
13224 do_cleanups (old_chain);
13225 return result;
13226}
13227
13228/* Implement the "info exceptions" command. */
13229
13230static void
13231info_exceptions_command (char *regexp, int from_tty)
13232{
13233 VEC(ada_exc_info) *exceptions;
13234 struct cleanup *cleanup;
13235 struct gdbarch *gdbarch = get_current_arch ();
13236 int ix;
13237 struct ada_exc_info *info;
13238
13239 exceptions = ada_exceptions_list (regexp);
13240 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
13241
13242 if (regexp != NULL)
13243 printf_filtered
13244 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13245 else
13246 printf_filtered (_("All defined Ada exceptions:\n"));
13247
13248 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
13249 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
13250
13251 do_cleanups (cleanup);
13252}
13253
4c4b4cd2
PH
13254 /* Operators */
13255/* Information about operators given special treatment in functions
13256 below. */
13257/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13258
13259#define ADA_OPERATORS \
13260 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13261 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13262 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13263 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13264 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13265 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13266 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13267 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13268 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13269 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13270 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13271 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13272 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13273 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13274 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
52ce6436
PH
13275 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13276 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13277 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13278 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
4c4b4cd2
PH
13279
13280static void
554794dc
SDJ
13281ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13282 int *argsp)
4c4b4cd2
PH
13283{
13284 switch (exp->elts[pc - 1].opcode)
13285 {
76a01679 13286 default:
4c4b4cd2
PH
13287 operator_length_standard (exp, pc, oplenp, argsp);
13288 break;
13289
13290#define OP_DEFN(op, len, args, binop) \
13291 case op: *oplenp = len; *argsp = args; break;
13292 ADA_OPERATORS;
13293#undef OP_DEFN
52ce6436
PH
13294
13295 case OP_AGGREGATE:
13296 *oplenp = 3;
13297 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13298 break;
13299
13300 case OP_CHOICES:
13301 *oplenp = 3;
13302 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13303 break;
4c4b4cd2
PH
13304 }
13305}
13306
c0201579
JK
13307/* Implementation of the exp_descriptor method operator_check. */
13308
13309static int
13310ada_operator_check (struct expression *exp, int pos,
13311 int (*objfile_func) (struct objfile *objfile, void *data),
13312 void *data)
13313{
13314 const union exp_element *const elts = exp->elts;
13315 struct type *type = NULL;
13316
13317 switch (elts[pos].opcode)
13318 {
13319 case UNOP_IN_RANGE:
13320 case UNOP_QUAL:
13321 type = elts[pos + 1].type;
13322 break;
13323
13324 default:
13325 return operator_check_standard (exp, pos, objfile_func, data);
13326 }
13327
13328 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13329
13330 if (type && TYPE_OBJFILE (type)
13331 && (*objfile_func) (TYPE_OBJFILE (type), data))
13332 return 1;
13333
13334 return 0;
13335}
13336
4c4b4cd2
PH
13337static char *
13338ada_op_name (enum exp_opcode opcode)
13339{
13340 switch (opcode)
13341 {
76a01679 13342 default:
4c4b4cd2 13343 return op_name_standard (opcode);
52ce6436 13344
4c4b4cd2
PH
13345#define OP_DEFN(op, len, args, binop) case op: return #op;
13346 ADA_OPERATORS;
13347#undef OP_DEFN
52ce6436
PH
13348
13349 case OP_AGGREGATE:
13350 return "OP_AGGREGATE";
13351 case OP_CHOICES:
13352 return "OP_CHOICES";
13353 case OP_NAME:
13354 return "OP_NAME";
4c4b4cd2
PH
13355 }
13356}
13357
13358/* As for operator_length, but assumes PC is pointing at the first
13359 element of the operator, and gives meaningful results only for the
52ce6436 13360 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
4c4b4cd2
PH
13361
13362static void
76a01679
JB
13363ada_forward_operator_length (struct expression *exp, int pc,
13364 int *oplenp, int *argsp)
4c4b4cd2 13365{
76a01679 13366 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
13367 {
13368 default:
13369 *oplenp = *argsp = 0;
13370 break;
52ce6436 13371
4c4b4cd2
PH
13372#define OP_DEFN(op, len, args, binop) \
13373 case op: *oplenp = len; *argsp = args; break;
13374 ADA_OPERATORS;
13375#undef OP_DEFN
52ce6436
PH
13376
13377 case OP_AGGREGATE:
13378 *oplenp = 3;
13379 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13380 break;
13381
13382 case OP_CHOICES:
13383 *oplenp = 3;
13384 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13385 break;
13386
13387 case OP_STRING:
13388 case OP_NAME:
13389 {
13390 int len = longest_to_int (exp->elts[pc + 1].longconst);
5b4ee69b 13391
52ce6436
PH
13392 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13393 *argsp = 0;
13394 break;
13395 }
4c4b4cd2
PH
13396 }
13397}
13398
13399static int
13400ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13401{
13402 enum exp_opcode op = exp->elts[elt].opcode;
13403 int oplen, nargs;
13404 int pc = elt;
13405 int i;
76a01679 13406
4c4b4cd2
PH
13407 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13408
76a01679 13409 switch (op)
4c4b4cd2 13410 {
76a01679 13411 /* Ada attributes ('Foo). */
4c4b4cd2
PH
13412 case OP_ATR_FIRST:
13413 case OP_ATR_LAST:
13414 case OP_ATR_LENGTH:
13415 case OP_ATR_IMAGE:
13416 case OP_ATR_MAX:
13417 case OP_ATR_MIN:
13418 case OP_ATR_MODULUS:
13419 case OP_ATR_POS:
13420 case OP_ATR_SIZE:
13421 case OP_ATR_TAG:
13422 case OP_ATR_VAL:
13423 break;
13424
13425 case UNOP_IN_RANGE:
13426 case UNOP_QUAL:
323e0a4a
AC
13427 /* XXX: gdb_sprint_host_address, type_sprint */
13428 fprintf_filtered (stream, _("Type @"));
4c4b4cd2
PH
13429 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13430 fprintf_filtered (stream, " (");
13431 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13432 fprintf_filtered (stream, ")");
13433 break;
13434 case BINOP_IN_BOUNDS:
52ce6436
PH
13435 fprintf_filtered (stream, " (%d)",
13436 longest_to_int (exp->elts[pc + 2].longconst));
4c4b4cd2
PH
13437 break;
13438 case TERNOP_IN_RANGE:
13439 break;
13440
52ce6436
PH
13441 case OP_AGGREGATE:
13442 case OP_OTHERS:
13443 case OP_DISCRETE_RANGE:
13444 case OP_POSITIONAL:
13445 case OP_CHOICES:
13446 break;
13447
13448 case OP_NAME:
13449 case OP_STRING:
13450 {
13451 char *name = &exp->elts[elt + 2].string;
13452 int len = longest_to_int (exp->elts[elt + 1].longconst);
5b4ee69b 13453
52ce6436
PH
13454 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13455 break;
13456 }
13457
4c4b4cd2
PH
13458 default:
13459 return dump_subexp_body_standard (exp, stream, elt);
13460 }
13461
13462 elt += oplen;
13463 for (i = 0; i < nargs; i += 1)
13464 elt = dump_subexp (exp, stream, elt);
13465
13466 return elt;
13467}
13468
13469/* The Ada extension of print_subexp (q.v.). */
13470
76a01679
JB
13471static void
13472ada_print_subexp (struct expression *exp, int *pos,
13473 struct ui_file *stream, enum precedence prec)
4c4b4cd2 13474{
52ce6436 13475 int oplen, nargs, i;
4c4b4cd2
PH
13476 int pc = *pos;
13477 enum exp_opcode op = exp->elts[pc].opcode;
13478
13479 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13480
52ce6436 13481 *pos += oplen;
4c4b4cd2
PH
13482 switch (op)
13483 {
13484 default:
52ce6436 13485 *pos -= oplen;
4c4b4cd2
PH
13486 print_subexp_standard (exp, pos, stream, prec);
13487 return;
13488
13489 case OP_VAR_VALUE:
4c4b4cd2
PH
13490 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13491 return;
13492
13493 case BINOP_IN_BOUNDS:
323e0a4a 13494 /* XXX: sprint_subexp */
4c4b4cd2 13495 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13496 fputs_filtered (" in ", stream);
4c4b4cd2 13497 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13498 fputs_filtered ("'range", stream);
4c4b4cd2 13499 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
13500 fprintf_filtered (stream, "(%ld)",
13501 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
13502 return;
13503
13504 case TERNOP_IN_RANGE:
4c4b4cd2 13505 if (prec >= PREC_EQUAL)
76a01679 13506 fputs_filtered ("(", stream);
323e0a4a 13507 /* XXX: sprint_subexp */
4c4b4cd2 13508 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13509 fputs_filtered (" in ", stream);
4c4b4cd2
PH
13510 print_subexp (exp, pos, stream, PREC_EQUAL);
13511 fputs_filtered (" .. ", stream);
13512 print_subexp (exp, pos, stream, PREC_EQUAL);
13513 if (prec >= PREC_EQUAL)
76a01679
JB
13514 fputs_filtered (")", stream);
13515 return;
4c4b4cd2
PH
13516
13517 case OP_ATR_FIRST:
13518 case OP_ATR_LAST:
13519 case OP_ATR_LENGTH:
13520 case OP_ATR_IMAGE:
13521 case OP_ATR_MAX:
13522 case OP_ATR_MIN:
13523 case OP_ATR_MODULUS:
13524 case OP_ATR_POS:
13525 case OP_ATR_SIZE:
13526 case OP_ATR_TAG:
13527 case OP_ATR_VAL:
4c4b4cd2 13528 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
13529 {
13530 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
79d43c61
TT
13531 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13532 &type_print_raw_options);
76a01679
JB
13533 *pos += 3;
13534 }
4c4b4cd2 13535 else
76a01679 13536 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
13537 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13538 if (nargs > 1)
76a01679
JB
13539 {
13540 int tem;
5b4ee69b 13541
76a01679
JB
13542 for (tem = 1; tem < nargs; tem += 1)
13543 {
13544 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13545 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13546 }
13547 fputs_filtered (")", stream);
13548 }
4c4b4cd2 13549 return;
14f9c5c9 13550
4c4b4cd2 13551 case UNOP_QUAL:
4c4b4cd2
PH
13552 type_print (exp->elts[pc + 1].type, "", stream, 0);
13553 fputs_filtered ("'(", stream);
13554 print_subexp (exp, pos, stream, PREC_PREFIX);
13555 fputs_filtered (")", stream);
13556 return;
14f9c5c9 13557
4c4b4cd2 13558 case UNOP_IN_RANGE:
323e0a4a 13559 /* XXX: sprint_subexp */
4c4b4cd2 13560 print_subexp (exp, pos, stream, PREC_SUFFIX);
0b48a291 13561 fputs_filtered (" in ", stream);
79d43c61
TT
13562 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13563 &type_print_raw_options);
4c4b4cd2 13564 return;
52ce6436
PH
13565
13566 case OP_DISCRETE_RANGE:
13567 print_subexp (exp, pos, stream, PREC_SUFFIX);
13568 fputs_filtered ("..", stream);
13569 print_subexp (exp, pos, stream, PREC_SUFFIX);
13570 return;
13571
13572 case OP_OTHERS:
13573 fputs_filtered ("others => ", stream);
13574 print_subexp (exp, pos, stream, PREC_SUFFIX);
13575 return;
13576
13577 case OP_CHOICES:
13578 for (i = 0; i < nargs-1; i += 1)
13579 {
13580 if (i > 0)
13581 fputs_filtered ("|", stream);
13582 print_subexp (exp, pos, stream, PREC_SUFFIX);
13583 }
13584 fputs_filtered (" => ", stream);
13585 print_subexp (exp, pos, stream, PREC_SUFFIX);
13586 return;
13587
13588 case OP_POSITIONAL:
13589 print_subexp (exp, pos, stream, PREC_SUFFIX);
13590 return;
13591
13592 case OP_AGGREGATE:
13593 fputs_filtered ("(", stream);
13594 for (i = 0; i < nargs; i += 1)
13595 {
13596 if (i > 0)
13597 fputs_filtered (", ", stream);
13598 print_subexp (exp, pos, stream, PREC_SUFFIX);
13599 }
13600 fputs_filtered (")", stream);
13601 return;
4c4b4cd2
PH
13602 }
13603}
14f9c5c9
AS
13604
13605/* Table mapping opcodes into strings for printing operators
13606 and precedences of the operators. */
13607
d2e4a39e
AS
13608static const struct op_print ada_op_print_tab[] = {
13609 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13610 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13611 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13612 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13613 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13614 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13615 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13616 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13617 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13618 {">=", BINOP_GEQ, PREC_ORDER, 0},
13619 {">", BINOP_GTR, PREC_ORDER, 0},
13620 {"<", BINOP_LESS, PREC_ORDER, 0},
13621 {">>", BINOP_RSH, PREC_SHIFT, 0},
13622 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13623 {"+", BINOP_ADD, PREC_ADD, 0},
13624 {"-", BINOP_SUB, PREC_ADD, 0},
13625 {"&", BINOP_CONCAT, PREC_ADD, 0},
13626 {"*", BINOP_MUL, PREC_MUL, 0},
13627 {"/", BINOP_DIV, PREC_MUL, 0},
13628 {"rem", BINOP_REM, PREC_MUL, 0},
13629 {"mod", BINOP_MOD, PREC_MUL, 0},
13630 {"**", BINOP_EXP, PREC_REPEAT, 0},
13631 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13632 {"-", UNOP_NEG, PREC_PREFIX, 0},
13633 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13634 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13635 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13636 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
13637 {".all", UNOP_IND, PREC_SUFFIX, 1},
13638 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13639 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
f486487f 13640 {NULL, OP_NULL, PREC_SUFFIX, 0}
14f9c5c9
AS
13641};
13642\f
72d5681a
PH
13643enum ada_primitive_types {
13644 ada_primitive_type_int,
13645 ada_primitive_type_long,
13646 ada_primitive_type_short,
13647 ada_primitive_type_char,
13648 ada_primitive_type_float,
13649 ada_primitive_type_double,
13650 ada_primitive_type_void,
13651 ada_primitive_type_long_long,
13652 ada_primitive_type_long_double,
13653 ada_primitive_type_natural,
13654 ada_primitive_type_positive,
13655 ada_primitive_type_system_address,
13656 nr_ada_primitive_types
13657};
6c038f32
PH
13658
13659static void
d4a9a881 13660ada_language_arch_info (struct gdbarch *gdbarch,
72d5681a
PH
13661 struct language_arch_info *lai)
13662{
d4a9a881 13663 const struct builtin_type *builtin = builtin_type (gdbarch);
5b4ee69b 13664
72d5681a 13665 lai->primitive_type_vector
d4a9a881 13666 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
72d5681a 13667 struct type *);
e9bb382b
UW
13668
13669 lai->primitive_type_vector [ada_primitive_type_int]
13670 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13671 0, "integer");
13672 lai->primitive_type_vector [ada_primitive_type_long]
13673 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13674 0, "long_integer");
13675 lai->primitive_type_vector [ada_primitive_type_short]
13676 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13677 0, "short_integer");
13678 lai->string_char_type
13679 = lai->primitive_type_vector [ada_primitive_type_char]
13680 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13681 lai->primitive_type_vector [ada_primitive_type_float]
13682 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13683 "float", NULL);
13684 lai->primitive_type_vector [ada_primitive_type_double]
13685 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13686 "long_float", NULL);
13687 lai->primitive_type_vector [ada_primitive_type_long_long]
13688 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13689 0, "long_long_integer");
13690 lai->primitive_type_vector [ada_primitive_type_long_double]
13691 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13692 "long_long_float", NULL);
13693 lai->primitive_type_vector [ada_primitive_type_natural]
13694 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13695 0, "natural");
13696 lai->primitive_type_vector [ada_primitive_type_positive]
13697 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13698 0, "positive");
13699 lai->primitive_type_vector [ada_primitive_type_void]
13700 = builtin->builtin_void;
13701
13702 lai->primitive_type_vector [ada_primitive_type_system_address]
13703 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
72d5681a
PH
13704 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13705 = "system__address";
fbb06eb1 13706
47e729a8 13707 lai->bool_type_symbol = NULL;
fbb06eb1 13708 lai->bool_type_default = builtin->builtin_bool;
6c038f32 13709}
6c038f32
PH
13710\f
13711 /* Language vector */
13712
13713/* Not really used, but needed in the ada_language_defn. */
13714
13715static void
6c7a06a3 13716emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
6c038f32 13717{
6c7a06a3 13718 ada_emit_char (c, type, stream, quoter, 1);
6c038f32
PH
13719}
13720
13721static int
410a0ff2 13722parse (struct parser_state *ps)
6c038f32
PH
13723{
13724 warnings_issued = 0;
410a0ff2 13725 return ada_parse (ps);
6c038f32
PH
13726}
13727
13728static const struct exp_descriptor ada_exp_descriptor = {
13729 ada_print_subexp,
13730 ada_operator_length,
c0201579 13731 ada_operator_check,
6c038f32
PH
13732 ada_op_name,
13733 ada_dump_subexp_body,
13734 ada_evaluate_subexp
13735};
13736
1a119f36 13737/* Implement the "la_get_symbol_name_cmp" language_defn method
74ccd7f5
JB
13738 for Ada. */
13739
1a119f36
JB
13740static symbol_name_cmp_ftype
13741ada_get_symbol_name_cmp (const char *lookup_name)
74ccd7f5
JB
13742{
13743 if (should_use_wild_match (lookup_name))
13744 return wild_match;
13745 else
13746 return compare_names;
13747}
13748
a5ee536b
JB
13749/* Implement the "la_read_var_value" language_defn method for Ada. */
13750
13751static struct value *
13752ada_read_var_value (struct symbol *var, struct frame_info *frame)
13753{
3977b71f 13754 const struct block *frame_block = NULL;
a5ee536b
JB
13755 struct symbol *renaming_sym = NULL;
13756
13757 /* The only case where default_read_var_value is not sufficient
13758 is when VAR is a renaming... */
13759 if (frame)
13760 frame_block = get_frame_block (frame, NULL);
13761 if (frame_block)
13762 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13763 if (renaming_sym != NULL)
13764 return ada_read_renaming_var_value (renaming_sym, frame_block);
13765
13766 /* This is a typical case where we expect the default_read_var_value
13767 function to work. */
13768 return default_read_var_value (var, frame);
13769}
13770
6c038f32
PH
13771const struct language_defn ada_language_defn = {
13772 "ada", /* Language name */
6abde28f 13773 "Ada",
6c038f32 13774 language_ada,
6c038f32 13775 range_check_off,
6c038f32
PH
13776 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13777 that's not quite what this means. */
6c038f32 13778 array_row_major,
9a044a89 13779 macro_expansion_no,
6c038f32
PH
13780 &ada_exp_descriptor,
13781 parse,
13782 ada_error,
13783 resolve,
13784 ada_printchar, /* Print a character constant */
13785 ada_printstr, /* Function to print string constant */
13786 emit_char, /* Function to print single char (not used) */
6c038f32 13787 ada_print_type, /* Print a type using appropriate syntax */
be942545 13788 ada_print_typedef, /* Print a typedef using appropriate syntax */
6c038f32
PH
13789 ada_val_print, /* Print a value using appropriate syntax */
13790 ada_value_print, /* Print a top-level value */
a5ee536b 13791 ada_read_var_value, /* la_read_var_value */
6c038f32 13792 NULL, /* Language specific skip_trampoline */
2b2d9e11 13793 NULL, /* name_of_this */
6c038f32
PH
13794 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13795 basic_lookup_transparent_type, /* lookup_transparent_type */
13796 ada_la_decode, /* Language specific symbol demangler */
0963b4bd
MS
13797 NULL, /* Language specific
13798 class_name_from_physname */
6c038f32
PH
13799 ada_op_print_tab, /* expression operators for printing */
13800 0, /* c-style arrays */
13801 1, /* String lower bound */
6c038f32 13802 ada_get_gdb_completer_word_break_characters,
41d27058 13803 ada_make_symbol_completion_list,
72d5681a 13804 ada_language_arch_info,
e79af960 13805 ada_print_array_index,
41f1b697 13806 default_pass_by_reference,
ae6a3a4c 13807 c_get_string,
1a119f36 13808 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
f8eba3c6 13809 ada_iterate_over_symbols,
a53b64ea 13810 &ada_varobj_ops,
bb2ec1b3
TT
13811 NULL,
13812 NULL,
6c038f32
PH
13813 LANG_MAGIC
13814};
13815
2c0b251b
PA
13816/* Provide a prototype to silence -Wmissing-prototypes. */
13817extern initialize_file_ftype _initialize_ada_language;
13818
5bf03f13
JB
13819/* Command-list for the "set/show ada" prefix command. */
13820static struct cmd_list_element *set_ada_list;
13821static struct cmd_list_element *show_ada_list;
13822
13823/* Implement the "set ada" prefix command. */
13824
13825static void
13826set_ada_command (char *arg, int from_tty)
13827{
13828 printf_unfiltered (_(\
13829"\"set ada\" must be followed by the name of a setting.\n"));
635c7e8a 13830 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
5bf03f13
JB
13831}
13832
13833/* Implement the "show ada" prefix command. */
13834
13835static void
13836show_ada_command (char *args, int from_tty)
13837{
13838 cmd_show_list (show_ada_list, from_tty, "");
13839}
13840
2060206e
PA
13841static void
13842initialize_ada_catchpoint_ops (void)
13843{
13844 struct breakpoint_ops *ops;
13845
13846 initialize_breakpoint_ops ();
13847
13848 ops = &catch_exception_breakpoint_ops;
13849 *ops = bkpt_breakpoint_ops;
13850 ops->dtor = dtor_catch_exception;
13851 ops->allocate_location = allocate_location_catch_exception;
13852 ops->re_set = re_set_catch_exception;
13853 ops->check_status = check_status_catch_exception;
13854 ops->print_it = print_it_catch_exception;
13855 ops->print_one = print_one_catch_exception;
13856 ops->print_mention = print_mention_catch_exception;
13857 ops->print_recreate = print_recreate_catch_exception;
13858
13859 ops = &catch_exception_unhandled_breakpoint_ops;
13860 *ops = bkpt_breakpoint_ops;
13861 ops->dtor = dtor_catch_exception_unhandled;
13862 ops->allocate_location = allocate_location_catch_exception_unhandled;
13863 ops->re_set = re_set_catch_exception_unhandled;
13864 ops->check_status = check_status_catch_exception_unhandled;
13865 ops->print_it = print_it_catch_exception_unhandled;
13866 ops->print_one = print_one_catch_exception_unhandled;
13867 ops->print_mention = print_mention_catch_exception_unhandled;
13868 ops->print_recreate = print_recreate_catch_exception_unhandled;
13869
13870 ops = &catch_assert_breakpoint_ops;
13871 *ops = bkpt_breakpoint_ops;
13872 ops->dtor = dtor_catch_assert;
13873 ops->allocate_location = allocate_location_catch_assert;
13874 ops->re_set = re_set_catch_assert;
13875 ops->check_status = check_status_catch_assert;
13876 ops->print_it = print_it_catch_assert;
13877 ops->print_one = print_one_catch_assert;
13878 ops->print_mention = print_mention_catch_assert;
13879 ops->print_recreate = print_recreate_catch_assert;
13880}
13881
3d9434b5
JB
13882/* This module's 'new_objfile' observer. */
13883
13884static void
13885ada_new_objfile_observer (struct objfile *objfile)
13886{
13887 ada_clear_symbol_cache ();
13888}
13889
13890/* This module's 'free_objfile' observer. */
13891
13892static void
13893ada_free_objfile_observer (struct objfile *objfile)
13894{
13895 ada_clear_symbol_cache ();
13896}
13897
d2e4a39e 13898void
6c038f32 13899_initialize_ada_language (void)
14f9c5c9 13900{
6c038f32
PH
13901 add_language (&ada_language_defn);
13902
2060206e
PA
13903 initialize_ada_catchpoint_ops ();
13904
5bf03f13
JB
13905 add_prefix_cmd ("ada", no_class, set_ada_command,
13906 _("Prefix command for changing Ada-specfic settings"),
13907 &set_ada_list, "set ada ", 0, &setlist);
13908
13909 add_prefix_cmd ("ada", no_class, show_ada_command,
13910 _("Generic command for showing Ada-specific settings."),
13911 &show_ada_list, "show ada ", 0, &showlist);
13912
13913 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13914 &trust_pad_over_xvs, _("\
13915Enable or disable an optimization trusting PAD types over XVS types"), _("\
13916Show whether an optimization trusting PAD types over XVS types is activated"),
13917 _("\
13918This is related to the encoding used by the GNAT compiler. The debugger\n\
13919should normally trust the contents of PAD types, but certain older versions\n\
13920of GNAT have a bug that sometimes causes the information in the PAD type\n\
13921to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13922work around this bug. It is always safe to turn this option \"off\", but\n\
13923this incurs a slight performance penalty, so it is recommended to NOT change\n\
13924this option to \"off\" unless necessary."),
13925 NULL, NULL, &set_ada_list, &show_ada_list);
13926
9ac4176b
PA
13927 add_catch_command ("exception", _("\
13928Catch Ada exceptions, when raised.\n\
13929With an argument, catch only exceptions with the given name."),
13930 catch_ada_exception_command,
13931 NULL,
13932 CATCH_PERMANENT,
13933 CATCH_TEMPORARY);
13934 add_catch_command ("assert", _("\
13935Catch failed Ada assertions, when raised.\n\
13936With an argument, catch only exceptions with the given name."),
13937 catch_assert_command,
13938 NULL,
13939 CATCH_PERMANENT,
13940 CATCH_TEMPORARY);
13941
6c038f32 13942 varsize_limit = 65536;
6c038f32 13943
778865d3
JB
13944 add_info ("exceptions", info_exceptions_command,
13945 _("\
13946List all Ada exception names.\n\
13947If a regular expression is passed as an argument, only those matching\n\
13948the regular expression are listed."));
13949
c6044dd1
JB
13950 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
13951 _("Set Ada maintenance-related variables."),
13952 &maint_set_ada_cmdlist, "maintenance set ada ",
13953 0/*allow-unknown*/, &maintenance_set_cmdlist);
13954
13955 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
13956 _("Show Ada maintenance-related variables"),
13957 &maint_show_ada_cmdlist, "maintenance show ada ",
13958 0/*allow-unknown*/, &maintenance_show_cmdlist);
13959
13960 add_setshow_boolean_cmd
13961 ("ignore-descriptive-types", class_maintenance,
13962 &ada_ignore_descriptive_types_p,
13963 _("Set whether descriptive types generated by GNAT should be ignored."),
13964 _("Show whether descriptive types generated by GNAT should be ignored."),
13965 _("\
13966When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13967DWARF attribute."),
13968 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13969
6c038f32
PH
13970 obstack_init (&symbol_list_obstack);
13971
13972 decoded_names_store = htab_create_alloc
13973 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13974 NULL, xcalloc, xfree);
6b69afc4 13975
3d9434b5
JB
13976 /* The ada-lang observers. */
13977 observer_attach_new_objfile (ada_new_objfile_observer);
13978 observer_attach_free_objfile (ada_free_objfile_observer);
e802dbe0 13979 observer_attach_inferior_exit (ada_inferior_exit);
ee01b665
JB
13980
13981 /* Setup various context-specific data. */
e802dbe0 13982 ada_inferior_data
8e260fc0 13983 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
ee01b665
JB
13984 ada_pspace_data_handle
13985 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14f9c5c9 13986}