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